CPRSV29_PSO_PSD.KIDs

KIDS Distribution saved on Mar 29, 2013@18:33:13
PSD*3*73
**KIDS**:PSO_PSD_V29 1.0^PSD*3.0*73^PSO*7.0*391^

**INSTALL NAME**
PSO_PSD_V29 1.0
"BLD",8437,0)
PSO_PSD_V29 1.0^^1^3130329^y
"BLD",8437,6.3)
10
"BLD",8437,10,0)
^9.63^2^2
"BLD",8437,10,1,0)
PSD*3.0*73^1
"BLD",8437,10,2,0)
PSO*7.0*391^1
"BLD",8437,10,"B","PSD*3.0*73",1)

"BLD",8437,10,"B","PSO*7.0*391",2)

"MBREQ")
0
"QUES","XPF1",0)
Y
"QUES","XPF1","??")
^D REP^XPDH
"QUES","XPF1","A")
Shall I write over your |FLAG| File
"QUES","XPF1","B")
YES
"QUES","XPF1","M")
D XPF1^XPDIQ
"QUES","XPF2",0)
Y
"QUES","XPF2","??")
^D DTA^XPDH
"QUES","XPF2","A")
Want my data |FLAG| yours
"QUES","XPF2","B")
YES
"QUES","XPF2","M")
D XPF2^XPDIQ
"QUES","XPI1",0)
YO
"QUES","XPI1","??")
^D INHIBIT^XPDH
"QUES","XPI1","A")
Want KIDS to INHIBIT LOGONs during the install
"QUES","XPI1","B")
NO
"QUES","XPI1","M")
D XPI1^XPDIQ
"QUES","XPM1",0)
PO^VA(200,:EM
"QUES","XPM1","??")
^D MG^XPDH
"QUES","XPM1","A")
Enter the Coordinator for Mail Group '|FLAG|'
"QUES","XPM1","B")

"QUES","XPM1","M")
D XPM1^XPDIQ
"QUES","XPO1",0)
Y
"QUES","XPO1","??")
^D MENU^XPDH
"QUES","XPO1","A")
Want KIDS to Rebuild Menu Trees Upon Completion of Install
"QUES","XPO1","B")
NO
"QUES","XPO1","M")
D XPO1^XPDIQ
"QUES","XPZ1",0)
Y
"QUES","XPZ1","??")
^D OPT^XPDH
"QUES","XPZ1","A")
Want to DISABLE Scheduled Options, Menu Options, and Protocols
"QUES","XPZ1","B")
NO
"QUES","XPZ1","M")
D XPZ1^XPDIQ
"QUES","XPZ2",0)
Y
"QUES","XPZ2","??")
^D RTN^XPDH
"QUES","XPZ2","A")
Want to MOVE routines to other CPUs
"QUES","XPZ2","B")
NO
"QUES","XPZ2","M")
D XPZ2^XPDIQ
"VER")
8.0^22.0
**INSTALL NAME**
PSD*3.0*73
"BLD",8078,0)
PSD*3.0*73^CONTROLLED SUBSTANCES^0^3130329^y
"BLD",8078,1,0)
^^169^169^3130328^
"BLD",8078,1,1,0)
This patch is being released as part of the DEA e-Prescribing of 
"BLD",8078,1,2,0)
Controlled Substances (CS) project using Public Key Infrastructure (PKI)
"BLD",8078,1,3,0)
to satisfy requirements requested by the Drug Enforcement Administration
"BLD",8078,1,4,0)
(DEA).
"BLD",8078,1,5,0)
The applications involved in this project along with their patch 
"BLD",8078,1,6,0)
numbers are listed below and the same order should be followed when
"BLD",8078,1,7,0)
installing the patches.
"BLD",8078,1,8,0)
 
"BLD",8078,1,9,0)
   APPLICATION                                            PATCH
"BLD",8078,1,10,0)
   -----------------------------------------------------------------
"BLD",8078,1,11,0)
   KERNEL V. 8.0                                          XU*8*580
"BLD",8078,1,12,0)
   PHARMACY DATA MANAGEMENT (PDM) V. 1.0                  PSS*1*166
"BLD",8078,1,13,0)
   COMPUTERIZED PATIENT RECORD SYSTEM (CPRS) V. 3.0       OR*3*306
"BLD",8078,1,14,0)
   CONTROLLED SUBSTANCES (CS) V. 3.0                      PSD*3*73
"BLD",8078,1,15,0)
   OUTPATIENT PHARMACY (OP) V. 7.0                        PSO*7*391
"BLD",8078,1,16,0)
 
"BLD",8078,1,17,0)
Note: Patches PSO*7*391 and PSD*3*73 are being released in the Kernel 
"BLD",8078,1,18,0)
      Installation and Distribution System (KIDS) multi-build distribution
"BLD",8078,1,19,0)
      CPRSV29_PSO_PSD. 
"BLD",8078,1,20,0)
 
"BLD",8078,1,21,0)
The following modifications and enhancements are included in this patch
"BLD",8078,1,22,0)
(PSD*3*73):
"BLD",8078,1,23,0)
 
"BLD",8078,1,24,0)
1. Digitally Signed CS Orders Report [PSD DIGITALLY SIGNED ORDERS]
"BLD",8078,1,25,0)
   --------------------------------------------------------------
"BLD",8078,1,26,0)
   a) This option is modified to allow the selection of specific CS
"BLD",8078,1,27,0)
      Schedules when running the report as seen below:
"BLD",8078,1,28,0)
  
"BLD",8078,1,29,0)
      ...
"BLD",8078,1,30,0)
   
"BLD",8078,1,31,0)
      Sort By: Drug// ?
"BLD",8078,1,32,0)
 
"BLD",8078,1,33,0)
      Enter a code from the list.
"BLD",8078,1,34,0)
 
"BLD",8078,1,35,0)
           Select one of the following:
"BLD",8078,1,36,0)
 
"BLD",8078,1,37,0)
             D         Drug
"BLD",8078,1,38,0)
             PR        Provider
"BLD",8078,1,39,0)
             PA        Patient
"BLD",8078,1,40,0)
             S         Schedule
"BLD",8078,1,41,0)
 
"BLD",8078,1,42,0)
      Sort By: Drug// Schedule
"BLD",8078,1,43,0)
 
"BLD",8078,1,44,0)
      Select controlled substance schedule(s)
"BLD",8078,1,45,0)
 
"BLD",8078,1,46,0)
        Select one of the following:
"BLD",8078,1,47,0)
    
"BLD",8078,1,48,0)
             1         SCHEDULE II
"BLD",8078,1,49,0)
             2         SCHEDULES III - V
"BLD",8078,1,50,0)
             3         SCHEDULES II - V
"BLD",8078,1,51,0)
 
"BLD",8078,1,52,0)
      Select Schedule(s): 3//
"BLD",8078,1,53,0)
 
"BLD",8078,1,54,0)
      ...
"BLD",8078,1,55,0)
  
"BLD",8078,1,56,0)
   b) Two new fields are being added to the report output: 'Detox #'
"BLD",8078,1,57,0)
      and '# of Refills'.
"BLD",8078,1,58,0)
    
"BLD",8078,1,59,0)
2. Digitally Signed OP Released Rx Report [PSD DIG. SIGNED RELEASED RX] 
"BLD",8078,1,60,0)
   --------------------------------------------------------------------   
"BLD",8078,1,61,0)
   a) This option is modified to allow the selection of specific CS 
"BLD",8078,1,62,0)
      Schedules when running the report as seen below:
"BLD",8078,1,63,0)
  
"BLD",8078,1,64,0)
      ...
"BLD",8078,1,65,0)
   
"BLD",8078,1,66,0)
      Start Date: T  (FEB 29, 2012)
"BLD",8078,1,67,0)
 
"BLD",8078,1,68,0)
      End Date: T  (FEB 29, 2012)
"BLD",8078,1,69,0)
 
"BLD",8078,1,70,0)
      Select a schedule(s)
"BLD",8078,1,71,0)
 
"BLD",8078,1,72,0)
        Select one of the following:
"BLD",8078,1,73,0)
  
"BLD",8078,1,74,0)
             1         SCHEDULE II
"BLD",8078,1,75,0)
             2         SCHEDULES III - V
"BLD",8078,1,76,0)
             3         SCHEDULES II - V
"BLD",8078,1,77,0)
 
"BLD",8078,1,78,0)
      Select Schedule(s): 3//
"BLD",8078,1,79,0)
 
"BLD",8078,1,80,0)
      ...
"BLD",8078,1,81,0)
 
"BLD",8078,1,82,0)
   b) Two new fields are being added to the report output: 'Detox #'
"BLD",8078,1,83,0)
      and '# of Refills'.
"BLD",8078,1,84,0)
 
"BLD",8078,1,85,0)
3. Inspector's Log for Controlled Substances [PSD PRINT INSPECTOR LOG]
"BLD",8078,1,86,0)
   -------------------------------------------------------------------
"BLD",8078,1,87,0)
   This option is modified to allow the selection of specific CS Schedules
"BLD",8078,1,88,0)
   when running the report as seen below:
"BLD",8078,1,89,0)
  
"BLD",8078,1,90,0)
      ...
"BLD",8078,1,91,0)
    
"BLD",8078,1,92,0)
      Select NAOU: <RET>
"BLD",8078,1,93,0)
 
"BLD",8078,1,94,0)
      All Controlled Substances or Selected Schedules?
"BLD",8078,1,95,0)
 
"BLD",8078,1,96,0)
           Select one of the following:
"BLD",8078,1,97,0)
 
"BLD",8078,1,98,0)
             1         SCHEDULES I - II
"BLD",8078,1,99,0)
             2         SCHEDULES III - V
"BLD",8078,1,100,0)
             3         SCHEDULES I - V
"BLD",8078,1,101,0)
 
"BLD",8078,1,102,0)
      Select Schedule(s): 3//   SCHEDULES I - V
"BLD",8078,1,103,0)
  
"BLD",8078,1,104,0)
      Do you wish to sort by Inventory Type? NO// 
"BLD",8078,1,105,0)
 
"BLD",8078,1,106,0)
      ...
"BLD",8078,1,107,0)
 
"BLD",8078,1,108,0)
4. List On-Hand Amounts [PSD ON-HAND] and List On-Hand Amounts [PSD
"BLD",8078,1,109,0)
   ON-HAND TECH]
"BLD",8078,1,110,0)
   ------------------------------------------------------------------
"BLD",8078,1,111,0)
   These options are modified to allow the selection of specific CS 
"BLD",8078,1,112,0)
   Schedules when running the report as seen below:
"BLD",8078,1,113,0)
  
"BLD",8078,1,114,0)
      ...
"BLD",8078,1,115,0)
      
"BLD",8078,1,116,0)
      Select Primary Dispensing Site: OPC VAULT//     
"BLD",8078,1,117,0)
      Select Schedule/Drug
"BLD",8078,1,118,0)
 
"BLD",8078,1,119,0)
        Select one of the following:
"BLD",8078,1,120,0)
 
"BLD",8078,1,121,0)
             1         SCHEDULES I - II
"BLD",8078,1,122,0)
             2         SCHEDULES III - V
"BLD",8078,1,123,0)
             3         SCHEDULES I - V
"BLD",8078,1,124,0)
             4         INDIVIDUAL DRUG
"BLD",8078,1,125,0)
 
"BLD",8078,1,126,0)
      Select Schedule(s): 3//   SCHEDULES I - V
"BLD",8078,1,127,0)
 
"BLD",8078,1,128,0)
      DEVICE: 
"BLD",8078,1,129,0)
  
"BLD",8078,1,130,0)
      ...
"BLD",8078,1,131,0)
 
"BLD",8078,1,132,0)
5. Inventory Sheet Print [PSD INVEN SHEET PRT]
"BLD",8078,1,133,0)
   -------------------------------------------
"BLD",8078,1,134,0)
   This option is modified to allow the selection of specific CS
"BLD",8078,1,135,0)
   Schedules when running the report as seen below:
"BLD",8078,1,136,0)
  
"BLD",8078,1,137,0)
      ...
"BLD",8078,1,138,0)
      
"BLD",8078,1,139,0)
      Select Primary Dispensing Site: OPC VAULT//     
"BLD",8078,1,140,0)
      Select Schedule/Drug
"BLD",8078,1,141,0)
 
"BLD",8078,1,142,0)
        Select one of the following:
"BLD",8078,1,143,0)
 
"BLD",8078,1,144,0)
             1         SCHEDULES I - II
"BLD",8078,1,145,0)
             2         SCHEDULES III - V
"BLD",8078,1,146,0)
             3         SCHEDULES I - V
"BLD",8078,1,147,0)
             4         INDIVIDUAL DRUG
"BLD",8078,1,148,0)
 
"BLD",8078,1,149,0)
      Select Schedule(s): 3//   SCHEDULES I - V
"BLD",8078,1,150,0)
 
"BLD",8078,1,151,0)
      DEVICE: 
"BLD",8078,1,152,0)
  
"BLD",8078,1,153,0)
      ...
"BLD",8078,1,154,0)
 
"BLD",8078,1,155,0)
6. Controlled Substance Prescriptions Report [PSD CS PRESCRIPTIONS REPORT]
"BLD",8078,1,156,0)
   -----------------------------------------------------------------------
"BLD",8078,1,157,0)
   This option is a new option. It will provide a report of digitally 
"BLD",8078,1,158,0)
   signed orders that have been filled for Schedules I-V CS. The report
"BLD",8078,1,159,0)
   will be for a date range with the option of including discontinued
"BLD",8078,1,160,0)
   and/or expired orders and various sort criteria, list by patient, by
"BLD",8078,1,161,0)
   provider, by drug and by schedule, etc. It will be an 80-column report
"BLD",8078,1,162,0)
   and will be queued to a printer.
"BLD",8078,1,163,0)
  
"BLD",8078,1,164,0)
7. DEA DATA - Waived Practitioner Report [PSD DEA SUBOXONE]
"BLD",8078,1,165,0)
   --------------------------------------------------------
"BLD",8078,1,166,0)
   This option is a new option. This report provides a list of patients 
"BLD",8078,1,167,0)
   that were prescribed Suboxone drugs. Two views are available, one with
"BLD",8078,1,168,0)
   details, and another with just the counts of Suboxone patients per
"BLD",8078,1,169,0)
   prescriber. 
"BLD",8078,4,0)
^9.64PA^^
"BLD",8078,6)
8^
"BLD",8078,6.3)
8
"BLD",8078,"KRN",0)
^9.67PA^779.2^20
"BLD",8078,"KRN",.4,0)
.4
"BLD",8078,"KRN",.401,0)
.401
"BLD",8078,"KRN",.402,0)
.402
"BLD",8078,"KRN",.403,0)
.403
"BLD",8078,"KRN",.5,0)
.5
"BLD",8078,"KRN",.84,0)
.84
"BLD",8078,"KRN",3.6,0)
3.6
"BLD",8078,"KRN",3.8,0)
3.8
"BLD",8078,"KRN",9.2,0)
9.2
"BLD",8078,"KRN",9.8,0)
9.8
"BLD",8078,"KRN",9.8,"NM",0)
^9.68A^11^11
"BLD",8078,"KRN",9.8,"NM",1,0)
PSDDSOR^^0^B86052358
"BLD",8078,"KRN",9.8,"NM",2,0)
PSDDSOR1^^0^B31741433
"BLD",8078,"KRN",9.8,"NM",3,0)
PSDDSOR2^^0^B23181227
"BLD",8078,"KRN",9.8,"NM",4,0)
PSDBAL^^0^B22121079
"BLD",8078,"KRN",9.8,"NM",5,0)
PSDPLOG^^0^B19818011
"BLD",8078,"KRN",9.8,"NM",6,0)
PSDPLOG1^^0^B25428029
"BLD",8078,"KRN",9.8,"NM",7,0)
PSDPLOG2^^0^B17681782
"BLD",8078,"KRN",9.8,"NM",8,0)
PSDPLOG3^^0^B20151384
"BLD",8078,"KRN",9.8,"NM",9,0)
PSDSUBOX^^0^B32552011
"BLD",8078,"KRN",9.8,"NM",10,0)
PSDBALI^^0^B28472924
"BLD",8078,"KRN",9.8,"NM",11,0)
PSDBALI1^^0^B5019533
"BLD",8078,"KRN",9.8,"NM","B","PSDBAL",4)

"BLD",8078,"KRN",9.8,"NM","B","PSDBALI",10)

"BLD",8078,"KRN",9.8,"NM","B","PSDBALI1",11)

"BLD",8078,"KRN",9.8,"NM","B","PSDDSOR",1)

"BLD",8078,"KRN",9.8,"NM","B","PSDDSOR1",2)

"BLD",8078,"KRN",9.8,"NM","B","PSDDSOR2",3)

"BLD",8078,"KRN",9.8,"NM","B","PSDPLOG",5)

"BLD",8078,"KRN",9.8,"NM","B","PSDPLOG1",6)

"BLD",8078,"KRN",9.8,"NM","B","PSDPLOG2",7)

"BLD",8078,"KRN",9.8,"NM","B","PSDPLOG3",8)

"BLD",8078,"KRN",9.8,"NM","B","PSDSUBOX",9)

"BLD",8078,"KRN",19,0)
19
"BLD",8078,"KRN",19,"NM",0)
^9.68A^3^3
"BLD",8078,"KRN",19,"NM",1,0)
PSD CS PRESCRIPTIONS REPORT^^0
"BLD",8078,"KRN",19,"NM",2,0)
PSD DEA SUBOXONE^^0
"BLD",8078,"KRN",19,"NM",3,0)
PSD PRODUCTION REPORTS^^2
"BLD",8078,"KRN",19,"NM","B","PSD CS PRESCRIPTIONS REPORT",1)

"BLD",8078,"KRN",19,"NM","B","PSD DEA SUBOXONE",2)

"BLD",8078,"KRN",19,"NM","B","PSD PRODUCTION REPORTS",3)

"BLD",8078,"KRN",19.1,0)
19.1
"BLD",8078,"KRN",19.1,"NM",0)
^9.68A^^0
"BLD",8078,"KRN",101,0)
101
"BLD",8078,"KRN",409.61,0)
409.61
"BLD",8078,"KRN",771,0)
771
"BLD",8078,"KRN",779.2,0)
779.2
"BLD",8078,"KRN",870,0)
870
"BLD",8078,"KRN",8989.51,0)
8989.51
"BLD",8078,"KRN",8989.52,0)
8989.52
"BLD",8078,"KRN",8994,0)
8994
"BLD",8078,"KRN","B",.4,.4)

"BLD",8078,"KRN","B",.401,.401)

"BLD",8078,"KRN","B",.402,.402)

"BLD",8078,"KRN","B",.403,.403)

"BLD",8078,"KRN","B",.5,.5)

"BLD",8078,"KRN","B",.84,.84)

"BLD",8078,"KRN","B",3.6,3.6)

"BLD",8078,"KRN","B",3.8,3.8)

"BLD",8078,"KRN","B",9.2,9.2)

"BLD",8078,"KRN","B",9.8,9.8)

"BLD",8078,"KRN","B",19,19)

"BLD",8078,"KRN","B",19.1,19.1)

"BLD",8078,"KRN","B",101,101)

"BLD",8078,"KRN","B",409.61,409.61)

"BLD",8078,"KRN","B",771,771)

"BLD",8078,"KRN","B",779.2,779.2)

"BLD",8078,"KRN","B",870,870)

"BLD",8078,"KRN","B",8989.51,8989.51)

"BLD",8078,"KRN","B",8989.52,8989.52)

"BLD",8078,"KRN","B",8994,8994)

"BLD",8078,"QDEF")
^^^^NO^^^^NO^^NO
"BLD",8078,"QUES",0)
^9.62^^
"BLD",8078,"REQB",0)
^9.611^3^3
"BLD",8078,"REQB",1,0)
PSD*3.0*28^2
"BLD",8078,"REQB",2,0)
PSD*3.0*67^2
"BLD",8078,"REQB",3,0)
PSS*1.0*166^2
"BLD",8078,"REQB","B","PSD*3.0*28",1)

"BLD",8078,"REQB","B","PSD*3.0*67",2)

"BLD",8078,"REQB","B","PSS*1.0*166",3)

"KRN",19,6722,-1)
2^3
"KRN",19,6722,0)
PSD PRODUCTION REPORTS^Production Reports^^M^11595^^^^^^^276
"KRN",19,6722,10,0)
^19.01IP^24^19
"KRN",19,6722,10,23,0)
13898
"KRN",19,6722,10,23,"^")
PSD DEA SUBOXONE
"KRN",19,6722,10,24,0)
13896
"KRN",19,6722,10,24,"^")
PSD CS PRESCRIPTIONS REPORT
"KRN",19,6722,"U")
PRODUCTION REPORTS
"KRN",19,13896,-1)
0^1
"KRN",19,13896,0)
PSD CS PRESCRIPTIONS REPORT^Controlled Substance Prescriptions Report^^R^^^^^^^^CONTROLLED SUBSTANCES^^1^1
"KRN",19,13896,1,0)
^19.06^6^6^3110815^^^^
"KRN",19,13896,1,1,0)
This option will provide a report of digitally signed orders that have been 
"KRN",19,13896,1,2,0)
filled for Schedules I-V controlled substances. The report will be for a date 
"KRN",19,13896,1,3,0)
range with the option of including discontinued and/or expired orders and 
"KRN",19,13896,1,4,0)
various sort criteria, list by patient, by provider, by drug and by schedule, 
"KRN",19,13896,1,5,0)
etc. It will be an 80-column report and will be queued to a printer.
"KRN",19,13896,1,6,0)

"KRN",19,13896,15)
K PSDCSRX
"KRN",19,13896,20)
S PSDCSRX=1
"KRN",19,13896,25)
PSDDSOR
"KRN",19,13896,"U")
CONTROLLED SUBSTANCE PRESCRIPT
"KRN",19,13898,-1)
0^2
"KRN",19,13898,0)
PSD DEA SUBOXONE^DEA DATA - Waived Practitioner Report^^R^^^^^^^^CONTROLLED SUBSTANCES
"KRN",19,13898,1,0)
^19.06^5^5^3120110^^
"KRN",19,13898,1,1,0)
This report provides a list of patients that were prescribed suboxone
"KRN",19,13898,1,2,0)
drugs. Two views are available, one with details, and another with just the 
"KRN",19,13898,1,3,0)
counts of suboxone patients per prescriber. 
"KRN",19,13898,1,4,0)

"KRN",19,13898,1,5,0)

"KRN",19,13898,25)
PSDSUBOX
"KRN",19,13898,"U")
DEA DATA - WAIVED PRACTITIONER
"MBREQ")
0
"ORD",18,19)
19;18;;;OPT^XPDTA;OPTF1^XPDIA;OPTE1^XPDIA;OPTF2^XPDIA;;OPTDEL^XPDIA
"ORD",18,19,0)
OPTION
"PKG",276,-1)
1^1
"PKG",276,0)
CONTROLLED SUBSTANCES^PSD^Controlled Substances Inventory and Tracking module.
"PKG",276,22,0)
^9.49I^1^1
"PKG",276,22,1,0)
3.0^2970213^2970430^11595
"PKG",276,22,1,"PAH",1,0)
73^3130329
"PKG",276,22,1,"PAH",1,1,0)
^^169^169^3130329
"PKG",276,22,1,"PAH",1,1,1,0)
This patch is being released as part of the DEA e-Prescribing of 
"PKG",276,22,1,"PAH",1,1,2,0)
Controlled Substances (CS) project using Public Key Infrastructure (PKI)
"PKG",276,22,1,"PAH",1,1,3,0)
to satisfy requirements requested by the Drug Enforcement Administration
"PKG",276,22,1,"PAH",1,1,4,0)
(DEA).
"PKG",276,22,1,"PAH",1,1,5,0)
The applications involved in this project along with their patch 
"PKG",276,22,1,"PAH",1,1,6,0)
numbers are listed below and the same order should be followed when
"PKG",276,22,1,"PAH",1,1,7,0)
installing the patches.
"PKG",276,22,1,"PAH",1,1,8,0)
 
"PKG",276,22,1,"PAH",1,1,9,0)
   APPLICATION                                            PATCH
"PKG",276,22,1,"PAH",1,1,10,0)
   -----------------------------------------------------------------
"PKG",276,22,1,"PAH",1,1,11,0)
   KERNEL V. 8.0                                          XU*8*580
"PKG",276,22,1,"PAH",1,1,12,0)
   PHARMACY DATA MANAGEMENT (PDM) V. 1.0                  PSS*1*166
"PKG",276,22,1,"PAH",1,1,13,0)
   COMPUTERIZED PATIENT RECORD SYSTEM (CPRS) V. 3.0       OR*3*306
"PKG",276,22,1,"PAH",1,1,14,0)
   CONTROLLED SUBSTANCES (CS) V. 3.0                      PSD*3*73
"PKG",276,22,1,"PAH",1,1,15,0)
   OUTPATIENT PHARMACY (OP) V. 7.0                        PSO*7*391
"PKG",276,22,1,"PAH",1,1,16,0)
 
"PKG",276,22,1,"PAH",1,1,17,0)
Note: Patches PSO*7*391 and PSD*3*73 are being released in the Kernel 
"PKG",276,22,1,"PAH",1,1,18,0)
      Installation and Distribution System (KIDS) multi-build distribution
"PKG",276,22,1,"PAH",1,1,19,0)
      CPRSV29_PSO_PSD. 
"PKG",276,22,1,"PAH",1,1,20,0)
 
"PKG",276,22,1,"PAH",1,1,21,0)
The following modifications and enhancements are included in this patch
"PKG",276,22,1,"PAH",1,1,22,0)
(PSD*3*73):
"PKG",276,22,1,"PAH",1,1,23,0)
 
"PKG",276,22,1,"PAH",1,1,24,0)
1. Digitally Signed CS Orders Report [PSD DIGITALLY SIGNED ORDERS]
"PKG",276,22,1,"PAH",1,1,25,0)
   --------------------------------------------------------------
"PKG",276,22,1,"PAH",1,1,26,0)
   a) This option is modified to allow the selection of specific CS
"PKG",276,22,1,"PAH",1,1,27,0)
      Schedules when running the report as seen below:
"PKG",276,22,1,"PAH",1,1,28,0)
  
"PKG",276,22,1,"PAH",1,1,29,0)
      ...
"PKG",276,22,1,"PAH",1,1,30,0)
   
"PKG",276,22,1,"PAH",1,1,31,0)
      Sort By: Drug// ?
"PKG",276,22,1,"PAH",1,1,32,0)
 
"PKG",276,22,1,"PAH",1,1,33,0)
      Enter a code from the list.
"PKG",276,22,1,"PAH",1,1,34,0)
 
"PKG",276,22,1,"PAH",1,1,35,0)
           Select one of the following:
"PKG",276,22,1,"PAH",1,1,36,0)
 
"PKG",276,22,1,"PAH",1,1,37,0)
             D         Drug
"PKG",276,22,1,"PAH",1,1,38,0)
             PR        Provider
"PKG",276,22,1,"PAH",1,1,39,0)
             PA        Patient
"PKG",276,22,1,"PAH",1,1,40,0)
             S         Schedule
"PKG",276,22,1,"PAH",1,1,41,0)
 
"PKG",276,22,1,"PAH",1,1,42,0)
      Sort By: Drug// Schedule
"PKG",276,22,1,"PAH",1,1,43,0)
 
"PKG",276,22,1,"PAH",1,1,44,0)
      Select controlled substance schedule(s)
"PKG",276,22,1,"PAH",1,1,45,0)
 
"PKG",276,22,1,"PAH",1,1,46,0)
        Select one of the following:
"PKG",276,22,1,"PAH",1,1,47,0)
    
"PKG",276,22,1,"PAH",1,1,48,0)
             1         SCHEDULE II
"PKG",276,22,1,"PAH",1,1,49,0)
             2         SCHEDULES III - V
"PKG",276,22,1,"PAH",1,1,50,0)
             3         SCHEDULES II - V
"PKG",276,22,1,"PAH",1,1,51,0)
 
"PKG",276,22,1,"PAH",1,1,52,0)
      Select Schedule(s): 3//
"PKG",276,22,1,"PAH",1,1,53,0)
 
"PKG",276,22,1,"PAH",1,1,54,0)
      ...
"PKG",276,22,1,"PAH",1,1,55,0)
  
"PKG",276,22,1,"PAH",1,1,56,0)
   b) Two new fields are being added to the report output: 'Detox #'
"PKG",276,22,1,"PAH",1,1,57,0)
      and '# of Refills'.
"PKG",276,22,1,"PAH",1,1,58,0)
    
"PKG",276,22,1,"PAH",1,1,59,0)
2. Digitally Signed OP Released Rx Report [PSD DIG. SIGNED RELEASED RX] 
"PKG",276,22,1,"PAH",1,1,60,0)
   --------------------------------------------------------------------   
"PKG",276,22,1,"PAH",1,1,61,0)
   a) This option is modified to allow the selection of specific CS 
"PKG",276,22,1,"PAH",1,1,62,0)
      Schedules when running the report as seen below:
"PKG",276,22,1,"PAH",1,1,63,0)
  
"PKG",276,22,1,"PAH",1,1,64,0)
      ...
"PKG",276,22,1,"PAH",1,1,65,0)
   
"PKG",276,22,1,"PAH",1,1,66,0)
      Start Date: T  (FEB 29, 2012)
"PKG",276,22,1,"PAH",1,1,67,0)
 
"PKG",276,22,1,"PAH",1,1,68,0)
      End Date: T  (FEB 29, 2012)
"PKG",276,22,1,"PAH",1,1,69,0)
 
"PKG",276,22,1,"PAH",1,1,70,0)
      Select a schedule(s)
"PKG",276,22,1,"PAH",1,1,71,0)
 
"PKG",276,22,1,"PAH",1,1,72,0)
        Select one of the following:
"PKG",276,22,1,"PAH",1,1,73,0)
  
"PKG",276,22,1,"PAH",1,1,74,0)
             1         SCHEDULE II
"PKG",276,22,1,"PAH",1,1,75,0)
             2         SCHEDULES III - V
"PKG",276,22,1,"PAH",1,1,76,0)
             3         SCHEDULES II - V
"PKG",276,22,1,"PAH",1,1,77,0)
 
"PKG",276,22,1,"PAH",1,1,78,0)
      Select Schedule(s): 3//
"PKG",276,22,1,"PAH",1,1,79,0)
 
"PKG",276,22,1,"PAH",1,1,80,0)
      ...
"PKG",276,22,1,"PAH",1,1,81,0)
 
"PKG",276,22,1,"PAH",1,1,82,0)
   b) Two new fields are being added to the report output: 'Detox #'
"PKG",276,22,1,"PAH",1,1,83,0)
      and '# of Refills'.
"PKG",276,22,1,"PAH",1,1,84,0)
 
"PKG",276,22,1,"PAH",1,1,85,0)
3. Inspector's Log for Controlled Substances [PSD PRINT INSPECTOR LOG]
"PKG",276,22,1,"PAH",1,1,86,0)
   -------------------------------------------------------------------
"PKG",276,22,1,"PAH",1,1,87,0)
   This option is modified to allow the selection of specific CS Schedules
"PKG",276,22,1,"PAH",1,1,88,0)
   when running the report as seen below:
"PKG",276,22,1,"PAH",1,1,89,0)
  
"PKG",276,22,1,"PAH",1,1,90,0)
      ...
"PKG",276,22,1,"PAH",1,1,91,0)
    
"PKG",276,22,1,"PAH",1,1,92,0)
      Select NAOU: <RET>
"PKG",276,22,1,"PAH",1,1,93,0)
 
"PKG",276,22,1,"PAH",1,1,94,0)
      All Controlled Substances or Selected Schedules?
"PKG",276,22,1,"PAH",1,1,95,0)
 
"PKG",276,22,1,"PAH",1,1,96,0)
           Select one of the following:
"PKG",276,22,1,"PAH",1,1,97,0)
 
"PKG",276,22,1,"PAH",1,1,98,0)
             1         SCHEDULES I - II
"PKG",276,22,1,"PAH",1,1,99,0)
             2         SCHEDULES III - V
"PKG",276,22,1,"PAH",1,1,100,0)
             3         SCHEDULES I - V
"PKG",276,22,1,"PAH",1,1,101,0)
 
"PKG",276,22,1,"PAH",1,1,102,0)
      Select Schedule(s): 3//   SCHEDULES I - V
"PKG",276,22,1,"PAH",1,1,103,0)
  
"PKG",276,22,1,"PAH",1,1,104,0)
      Do you wish to sort by Inventory Type? NO// 
"PKG",276,22,1,"PAH",1,1,105,0)
 
"PKG",276,22,1,"PAH",1,1,106,0)
      ...
"PKG",276,22,1,"PAH",1,1,107,0)
 
"PKG",276,22,1,"PAH",1,1,108,0)
4. List On-Hand Amounts [PSD ON-HAND] and List On-Hand Amounts [PSD
"PKG",276,22,1,"PAH",1,1,109,0)
   ON-HAND TECH]
"PKG",276,22,1,"PAH",1,1,110,0)
   ------------------------------------------------------------------
"PKG",276,22,1,"PAH",1,1,111,0)
   These options are modified to allow the selection of specific CS 
"PKG",276,22,1,"PAH",1,1,112,0)
   Schedules when running the report as seen below:
"PKG",276,22,1,"PAH",1,1,113,0)
  
"PKG",276,22,1,"PAH",1,1,114,0)
      ...
"PKG",276,22,1,"PAH",1,1,115,0)
      
"PKG",276,22,1,"PAH",1,1,116,0)
      Select Primary Dispensing Site: OPC VAULT//     
"PKG",276,22,1,"PAH",1,1,117,0)
      Select Schedule/Drug
"PKG",276,22,1,"PAH",1,1,118,0)
 
"PKG",276,22,1,"PAH",1,1,119,0)
        Select one of the following:
"PKG",276,22,1,"PAH",1,1,120,0)
 
"PKG",276,22,1,"PAH",1,1,121,0)
             1         SCHEDULES I - II
"PKG",276,22,1,"PAH",1,1,122,0)
             2         SCHEDULES III - V
"PKG",276,22,1,"PAH",1,1,123,0)
             3         SCHEDULES I - V
"PKG",276,22,1,"PAH",1,1,124,0)
             4         INDIVIDUAL DRUG
"PKG",276,22,1,"PAH",1,1,125,0)
 
"PKG",276,22,1,"PAH",1,1,126,0)
      Select Schedule(s): 3//   SCHEDULES I - V
"PKG",276,22,1,"PAH",1,1,127,0)
 
"PKG",276,22,1,"PAH",1,1,128,0)
      DEVICE: 
"PKG",276,22,1,"PAH",1,1,129,0)
  
"PKG",276,22,1,"PAH",1,1,130,0)
      ...
"PKG",276,22,1,"PAH",1,1,131,0)
 
"PKG",276,22,1,"PAH",1,1,132,0)
5. Inventory Sheet Print [PSD INVEN SHEET PRT]
"PKG",276,22,1,"PAH",1,1,133,0)
   -------------------------------------------
"PKG",276,22,1,"PAH",1,1,134,0)
   This option is modified to allow the selection of specific CS
"PKG",276,22,1,"PAH",1,1,135,0)
   Schedules when running the report as seen below:
"PKG",276,22,1,"PAH",1,1,136,0)
  
"PKG",276,22,1,"PAH",1,1,137,0)
      ...
"PKG",276,22,1,"PAH",1,1,138,0)
      
"PKG",276,22,1,"PAH",1,1,139,0)
      Select Primary Dispensing Site: OPC VAULT//     
"PKG",276,22,1,"PAH",1,1,140,0)
      Select Schedule/Drug
"PKG",276,22,1,"PAH",1,1,141,0)
 
"PKG",276,22,1,"PAH",1,1,142,0)
        Select one of the following:
"PKG",276,22,1,"PAH",1,1,143,0)
 
"PKG",276,22,1,"PAH",1,1,144,0)
             1         SCHEDULES I - II
"PKG",276,22,1,"PAH",1,1,145,0)
             2         SCHEDULES III - V
"PKG",276,22,1,"PAH",1,1,146,0)
             3         SCHEDULES I - V
"PKG",276,22,1,"PAH",1,1,147,0)
             4         INDIVIDUAL DRUG
"PKG",276,22,1,"PAH",1,1,148,0)
 
"PKG",276,22,1,"PAH",1,1,149,0)
      Select Schedule(s): 3//   SCHEDULES I - V
"PKG",276,22,1,"PAH",1,1,150,0)
 
"PKG",276,22,1,"PAH",1,1,151,0)
      DEVICE: 
"PKG",276,22,1,"PAH",1,1,152,0)
  
"PKG",276,22,1,"PAH",1,1,153,0)
      ...
"PKG",276,22,1,"PAH",1,1,154,0)
 
"PKG",276,22,1,"PAH",1,1,155,0)
6. Controlled Substance Prescriptions Report [PSD CS PRESCRIPTIONS REPORT]
"PKG",276,22,1,"PAH",1,1,156,0)
   -----------------------------------------------------------------------
"PKG",276,22,1,"PAH",1,1,157,0)
   This option is a new option. It will provide a report of digitally 
"PKG",276,22,1,"PAH",1,1,158,0)
   signed orders that have been filled for Schedules I-V CS. The report
"PKG",276,22,1,"PAH",1,1,159,0)
   will be for a date range with the option of including discontinued
"PKG",276,22,1,"PAH",1,1,160,0)
   and/or expired orders and various sort criteria, list by patient, by
"PKG",276,22,1,"PAH",1,1,161,0)
   provider, by drug and by schedule, etc. It will be an 80-column report
"PKG",276,22,1,"PAH",1,1,162,0)
   and will be queued to a printer.
"PKG",276,22,1,"PAH",1,1,163,0)
  
"PKG",276,22,1,"PAH",1,1,164,0)
7. DEA DATA - Waived Practitioner Report [PSD DEA SUBOXONE]
"PKG",276,22,1,"PAH",1,1,165,0)
   --------------------------------------------------------
"PKG",276,22,1,"PAH",1,1,166,0)
   This option is a new option. This report provides a list of patients 
"PKG",276,22,1,"PAH",1,1,167,0)
   that were prescribed Suboxone drugs. Two views are available, one with
"PKG",276,22,1,"PAH",1,1,168,0)
   details, and another with just the counts of Suboxone patients per
"PKG",276,22,1,"PAH",1,1,169,0)
   prescriber. 
"QUES","XPF1",0)
Y
"QUES","XPF1","??")
^D REP^XPDH
"QUES","XPF1","A")
Shall I write over your |FLAG| File
"QUES","XPF1","B")
YES
"QUES","XPF1","M")
D XPF1^XPDIQ
"QUES","XPF2",0)
Y
"QUES","XPF2","??")
^D DTA^XPDH
"QUES","XPF2","A")
Want my data |FLAG| yours
"QUES","XPF2","B")
YES
"QUES","XPF2","M")
D XPF2^XPDIQ
"QUES","XPI1",0)
YO
"QUES","XPI1","??")
^D INHIBIT^XPDH
"QUES","XPI1","A")
Want KIDS to INHIBIT LOGONs during the install
"QUES","XPI1","B")
NO
"QUES","XPI1","M")
D XPI1^XPDIQ
"QUES","XPM1",0)
PO^VA(200,:EM
"QUES","XPM1","??")
^D MG^XPDH
"QUES","XPM1","A")
Enter the Coordinator for Mail Group '|FLAG|'
"QUES","XPM1","B")

"QUES","XPM1","M")
D XPM1^XPDIQ
"QUES","XPO1",0)
Y
"QUES","XPO1","??")
^D MENU^XPDH
"QUES","XPO1","A")
Want KIDS to Rebuild Menu Trees Upon Completion of Install
"QUES","XPO1","B")
NO
"QUES","XPO1","M")
D XPO1^XPDIQ
"QUES","XPZ1",0)
Y
"QUES","XPZ1","??")
^D OPT^XPDH
"QUES","XPZ1","A")
Want to DISABLE Scheduled Options, Menu Options, and Protocols
"QUES","XPZ1","B")
NO
"QUES","XPZ1","M")
D XPZ1^XPDIQ
"QUES","XPZ2",0)
Y
"QUES","XPZ2","??")
^D RTN^XPDH
"QUES","XPZ2","A")
Want to MOVE routines to other CPUs
"QUES","XPZ2","B")
NO
"QUES","XPZ2","M")
D XPZ2^XPDIQ
"RTN")
11
"RTN","PSDBAL")
0^4^B22121079^B16952502
"RTN","PSDBAL",1,0)
PSDBAL ;BIR/JPW - Display/Print Current Drug Balance ;29 Aug 94
"RTN","PSDBAL",2,0)
 ;;3.0;CONTROLLED SUBSTANCES;**73**;13 Feb 97;Build 8
"RTN","PSDBAL",3,0)
 I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE)
"RTN","PSDBAL",4,0)
 I '$D(^XUSEC("PSJ RPHARM",DUZ))&('$D(^XUSEC("PSD TECH",DUZ))) W !!,"Contact your Pharmacy Coordinator for access to display current CS drug",!,"balances.",!!,"PSJ RPHARM or PSD TECH security key required.",! Q
"RTN","PSDBAL",5,0)
ASKD ;ask disp location
"RTN","PSDBAL",6,0)
 S PSDS=$P(PSDSITE,U,3),PSDSN=$P(PSDSITE,U,4)
"RTN","PSDBAL",7,0)
 G:$P(PSDSITE,U,5) CHKD
"RTN","PSDBAL",8,0)
 K DIC,DA S DIC=58.8,DIC(0)="QEAZ",DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S($P(^(0),""^"",2)[""M"":1,$P(^(0),""^"",2)[""S"":1,1:0)"
"RTN","PSDBAL",9,0)
 S DIC("A")="Select Primary Dispensing Site: "
"RTN","PSDBAL",10,0)
 S DIC("B")=PSDSN
"RTN","PSDBAL",11,0)
 D ^DIC K DIC G:Y<0 END
"RTN","PSDBAL",12,0)
 S PSDS=+Y,PSDSN=$P(Y,"^",2),$P(PSDSITE,U,3)=+Y,$P(PSDSITE,U,4)=PSDSN
"RTN","PSDBAL",13,0)
CHKD I '$O(^PSD(58.8,PSDS,1,0)) W !!,"There are no CS stocked drugs for your dispensing vault.",!! G END
"RTN","PSDBAL",14,0)
DRUG ;ask schedule/drug
"RTN","PSDBAL",15,0)
 W !,"Select Schedule/Drug"
"RTN","PSDBAL",16,0)
 N DIR,I,J,K
"RTN","PSDBAL",17,0)
 S DIR(0)="S^1:SCHEDULES I - II;2:SCHEDULES III - V;3:SCHEDULES I - V;4:INDIVIDUAL DRUG",DIR("A")="Select Schedule(s)",DIR("B")=3
"RTN","PSDBAL",18,0)
 D ^DIR
"RTN","PSDBAL",19,0)
 I $D(DIRUT) G END
"RTN","PSDBAL",20,0)
 K SCH S SCH=+Y I SCH<4 D  G DEV
"RTN","PSDBAL",21,0)
 .S I=$S(Y=2:3,1:1),J=$S(Y=1:2,1:5) F K=I:1:J S SCH(K)=""
"RTN","PSDBAL",22,0)
 W !!,?5,"You may select a single drug, several drugs,",!,?5,"or enter ^ALL to select all drugs.",!
"RTN","PSDBAL",23,0)
 W ! K DA,DIC
"RTN","PSDBAL",24,0)
 F  S DIC("W")="W:$P(^PSDRUG(Y,0),""^"",9) ""   N/F"" I $P(^PSD(58.8,PSDS,1,Y,0),""^"",14)]"""",$P(^(0),""^"",14)'>DT W $C(7),""   *** INACTIVE ***""",DA(1)=+PSDS,DIC(0)="QEAM",DIC="^PSD(58.8,"_PSDS_",1," D ^DIC K DIC Q:Y<0  D
"RTN","PSDBAL",25,0)
 .S PSDR(+Y)=""
"RTN","PSDBAL",26,0)
 S X=$$UP^XLFSTR(X)
"RTN","PSDBAL",27,0)
 I '$D(PSDR)&(X'="^ALL") G END
"RTN","PSDBAL",28,0)
 I X="^ALL" S ALL=1
"RTN","PSDBAL",29,0)
DEV ;sel device
"RTN","PSDBAL",30,0)
 S Y=$P($G(^PSD(58.8,+PSDS,2)),"^",9),C=$P(^DD(58.8,24,0),"^",2) D Y^DIQ S PSDEV=Y
"RTN","PSDBAL",31,0)
 W ! K %ZIS,IOP,IO("Q"),POP S %ZIS="QM",%ZIS("B")=PSDEV D ^%ZIS I POP W !!,"NO DEVICE SELECTED OR REPORT PRINTED!!",! G END
"RTN","PSDBAL",32,0)
 I $D(IO("Q")) K IO("Q"),ZTIO,ZTSAVE,ZTDTH,ZTSK S ZTRTN="START^PSDBAL",ZTDESC="CS PHARM List Stock Balances" D SAVE,^%ZTLOAD,HOME^%ZIS K ZTSK G END
"RTN","PSDBAL",33,0)
 U IO
"RTN","PSDBAL",34,0)
START ;entry for compile
"RTN","PSDBAL",35,0)
 K ^TMP("PSDBAL",$J)
"RTN","PSDBAL",36,0)
 I $D(ALL)!$G(SCH)<4 F PSD=0:0 S PSD=$O(^PSD(58.8,+PSDS,1,PSD)) Q:'PSD  I $D(^PSD(58.8,+PSDS,1,PSD,0)) D
"RTN","PSDBAL",37,0)
 .S DEA=+$P($G(^PSDRUG(PSD,0)),"^",3)
"RTN","PSDBAL",38,0)
 .I '$D(ALL) Q:'$D(SCH(DEA))
"RTN","PSDBAL",39,0)
 .S PSDR(+PSD)=""
"RTN","PSDBAL",40,0)
 F PSD=0:0 S PSD=$O(PSDR(PSD)) Q:'PSD  I $D(^PSD(58.8,+PSDS,1,PSD,0)) S NODE=^(0) D
"RTN","PSDBAL",41,0)
 .S PSDOK="" I +$P(NODE,"^",14),+$P(NODE,"^",14)'>DT Q:'+$P(NODE,"^",4)  S PSDOK="*"
"RTN","PSDBAL",42,0)
 .S BAL=+$P(NODE,"^",4),PSDRN=$S($P($G(^PSDRUG(+PSD,0)),"^")]"":$P(^(0),"^"),1:"ZZ/"_PSD_" NAME MISSING"),EXP=$S(+$P(NODE,"^",12):+$P(NODE,"^",12),1:"")
"RTN","PSDBAL",43,0)
 .I EXP S Y=EXP X ^DD("DD") S EXP=Y
"RTN","PSDBAL",44,0)
 .S ^TMP("PSDBAL",$J,PSDRN,PSD)=BAL_"^"_PSDOK_"^"_EXP_"^"_$P($G(^PSDRUG(+PSD,0)),"^",3)
"RTN","PSDBAL",45,0)
PRINT ;prints data
"RTN","PSDBAL",46,0)
 S (PG,PSDOUT)=0 D NOW^%DTC S Y=+$E(%,1,12) X ^DD("DD") S RPDT=Y
"RTN","PSDBAL",47,0)
 K LN S $P(LN,"-",80)="" D HDR
"RTN","PSDBAL",48,0)
 I '$D(^TMP("PSDBAL",$J)) W !!,?15,"**** NO STOCK BALANCE DATA AVAILABLE ****",!! G DONE
"RTN","PSDBAL",49,0)
 S PSDR="" F  S PSDR=$O(^TMP("PSDBAL",$J,PSDR)) Q:PSDR=""!(PSDOUT)  F PSD=0:0 S PSD=$O(^TMP("PSDBAL",$J,PSDR,PSD)) Q:'PSD  D
"RTN","PSDBAL",50,0)
 .D:$Y+4>IOSL HDR Q:PSDOUT
"RTN","PSDBAL",51,0)
 .S NODE=^TMP("PSDBAL",$J,PSDR,PSD),BAL=+NODE,PSDOK=$P(NODE,"^",2),EXP=$P(NODE,"^",3)
"RTN","PSDBAL",52,0)
 .W !,PSDOK,?2,PSDR,?53,$$SCH(+$P(NODE,"^",4)),?63,$J(BAL,6),! W:EXP]"" ?5,"Expiration Date: ",EXP,!
"RTN","PSDBAL",53,0)
DONE I $E(IOST)'="C" W @IOF
"RTN","PSDBAL",54,0)
 I $E(IOST,1,2)="C-",'PSDOUT W ! K DIR,DIRUT S DIR(0)="EA",DIR("A")="END OF REPORT!  Press <RET> to return to the menu" D ^DIR K DIR
"RTN","PSDBAL",55,0)
END ;
"RTN","PSDBAL",56,0)
 K %,%H,%I,%ZIS,ALL,BAL,C,DA,DIC,DTOUT,DUOUT,EXP,LN,NODE,PG,POP,PSD,PSDEV,PSDOK,PSDOUT,PSDR,PSDRN,PSDS,PSDSN,RPDT,X,Y,DEA
"RTN","PSDBAL",57,0)
 K ^TMP("PSDBAL",$J),ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
"RTN","PSDBAL",58,0)
 D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
"RTN","PSDBAL",59,0)
 Q
"RTN","PSDBAL",60,0)
SAVE S (ZTSAVE("PSDS"),ZTSAVE("PSDSN"),ZTSAVE("PSDSITE"),ZTSAVE("SCH"),ZTSAVE("SCH("))=""
"RTN","PSDBAL",61,0)
 S:$D(ALL) ZTSAVE("ALL")="" S:$D(PSDR) ZTSAVE("PSDR(")=""
"RTN","PSDBAL",62,0)
 Q
"RTN","PSDBAL",63,0)
HDR ;header
"RTN","PSDBAL",64,0)
 I $E(IOST,1,2)="C-",PG K DA,DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSDOUT=1 Q
"RTN","PSDBAL",65,0)
 S PG=PG+1 W:$Y @IOF W !,?12,"Current Stock Balances for ",PSDSN,?72,"Page: ",PG,!,?20,$S(SCH=1:"Schedules I - II",SCH=2:"Schedules III - V",SCH=3:"Schedules I - V",1:""),!?20,RPDT,!!
"RTN","PSDBAL",66,0)
 W ?5,"DRUG",?50,"SCHEDULE",?61,"CURRENT BALANCE",!,LN,!!
"RTN","PSDBAL",67,0)
 Q
"RTN","PSDBAL",68,0)
SCH(X) ;Schedule conversion
"RTN","PSDBAL",69,0)
 Q:(X'?.N)!(+X<1) ""
"RTN","PSDBAL",70,0)
 Q $P("I^II^III^IV^V","^",X)
"RTN","PSDBALI")
0^10^B28472924^B22304429
"RTN","PSDBALI",1,0)
PSDBALI ;BIR/JPW-Display/Print Drug Inv Sheet & Balance ; 29 Aug 94
"RTN","PSDBALI",2,0)
 ;;3.0;CONTROLLED SUBSTANCES;**73**;13 Feb 97;Build 8
"RTN","PSDBALI",3,0)
 I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE)
"RTN","PSDBALI",4,0)
ASKD ;ask disp location
"RTN","PSDBALI",5,0)
 S PSDS=$P(PSDSITE,U,3),PSDSN=$P(PSDSITE,U,4)
"RTN","PSDBALI",6,0)
 G:$P(PSDSITE,U,5) CHKD
"RTN","PSDBALI",7,0)
 K DIC,DA S DIC=58.8,DIC(0)="QEAZ",DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S($P(^(0),""^"",2)[""M"":1,$P(^(0),""^"",2)[""S"":1,1:0)"
"RTN","PSDBALI",8,0)
 S DIC("A")="Select Primary Dispensing Site: "
"RTN","PSDBALI",9,0)
 S DIC("B")=PSDSN
"RTN","PSDBALI",10,0)
 D ^DIC K DIC G:Y<0 END
"RTN","PSDBALI",11,0)
 S PSDS=+Y,PSDSN=$P(Y,"^",2),$P(PSDSITE,U,3)=+Y,$P(PSDSITE,U,4)=PSDSN
"RTN","PSDBALI",12,0)
CHKD I '$O(^PSD(58.8,PSDS,1,0)) W !!,"There are no CS stocked drugs for your dispensing vault.",!! G END
"RTN","PSDBALI",13,0)
SORT ;asks sort
"RTN","PSDBALI",14,0)
 W ! K DA,DIR,DIRUT S DIR(0)="YO",DIR("A")="Do you wish to sort by Inventory Type",DIR("B")="NO"
"RTN","PSDBALI",15,0)
 S DIR("?")="Answer YES to sort drugs by Inventory Type, NO or <RET> to sort by drug."
"RTN","PSDBALI",16,0)
 D ^DIR K DIR G:$D(DIRUT) END S ASKN=Y
"RTN","PSDBALI",17,0)
DRUG ;ask schedule/drug
"RTN","PSDBALI",18,0)
 W !,"Select Schedule/Drug"
"RTN","PSDBALI",19,0)
 N DIR,I,J,K
"RTN","PSDBALI",20,0)
 S DIR(0)="S^1:SCHEDULES I - II;2:SCHEDULES III - V;3:SCHEDULES I - V;4:INDIVIDUAL DRUG",DIR("A")="Select Schedule(s)",DIR("B")=3
"RTN","PSDBALI",21,0)
 D ^DIR
"RTN","PSDBALI",22,0)
 I $D(DIRUT) G END
"RTN","PSDBALI",23,0)
 S SCH=+Y I SCH<4 D  G DEV
"RTN","PSDBALI",24,0)
 .S I=$S(Y=2:3,1:1),J=$S(Y=1:2,1:5) F K=I:1:J S SCH(K)=""
"RTN","PSDBALI",25,0)
 W !!,?5,"You may select a single drug, several drugs,",!,?5,"or enter ^ALL to select all drugs.",!
"RTN","PSDBALI",26,0)
 W ! K DA,DIC
"RTN","PSDBALI",27,0)
 F  S DIC("W")="W:$P(^PSDRUG(Y,0),""^"",9) ""   N/F"" I $P(^PSD(58.8,PSDS,1,Y,0),""^"",14)]"""",$P(^(0),""^"",14)'>DT W $C(7),""   *** INACTIVE ***""",DA(1)=+PSDS,DIC(0)="QEAM",DIC="^PSD(58.8,"_PSDS_",1," D ^DIC K DIC Q:Y<0  D
"RTN","PSDBALI",28,0)
 .S PSDR(+Y)=""
"RTN","PSDBALI",29,0)
 S X=$$UP^XLFSTR(X)
"RTN","PSDBALI",30,0)
 I '$D(PSDR)&(X'="^ALL") G END
"RTN","PSDBALI",31,0)
 I X="^ALL" S ALL=1
"RTN","PSDBALI",32,0)
DEV ;sel device
"RTN","PSDBALI",33,0)
 S Y=$P($G(^PSD(58.8,+PSDS,2)),"^",9),C=$P(^DD(58.8,24,0),"^",2) D Y^DIQ S PSDEV=Y
"RTN","PSDBALI",34,0)
 W ! K %ZIS,IOP,IO("Q"),POP S %ZIS="QM",%ZIS("B")=PSDEV D ^%ZIS I POP W !!,"NO DEVICE SELECTED OR REPORT PRINTED!!",! G END
"RTN","PSDBALI",35,0)
 I $D(IO("Q")) K IO("Q"),ZTIO,ZTSAVE,ZTDTH,ZTSK S ZTRTN="START^PSDBALI",ZTDESC="CS PHARM Print Inv Sheet " D SAVE,^%ZTLOAD,HOME^%ZIS K ZTSK G END
"RTN","PSDBALI",36,0)
 U IO
"RTN","PSDBALI",37,0)
START ;entry for compile
"RTN","PSDBALI",38,0)
 K ^TMP("PSDBALI",$J)
"RTN","PSDBALI",39,0)
 I $D(ALL)!$G(SCH)<4 F PSD=0:0 S PSD=$O(^PSD(58.8,+PSDS,1,PSD)) Q:'PSD  I $D(^PSD(58.8,+PSDS,1,PSD,0)) D
"RTN","PSDBALI",40,0)
 .S DEA=+$P($G(^PSDRUG(PSD,0)),"^",3)
"RTN","PSDBALI",41,0)
 .I '$D(ALL) Q:'$D(SCH(DEA))
"RTN","PSDBALI",42,0)
 .S PSDR(+PSD)=""
"RTN","PSDBALI",43,0)
 F PSD=0:0 S PSD=$O(PSDR(PSD)) Q:'PSD  I $D(^PSD(58.8,+PSDS,1,PSD,0)) S NODE=^(0) D
"RTN","PSDBALI",44,0)
 .S PSDOK="" I +$P(NODE,"^",14),+$P(NODE,"^",14)'>DT Q:'+$P(NODE,"^",4)  S PSDOK="*"
"RTN","PSDBALI",45,0)
 .S BAL=+$P(NODE,"^",4),DRUGN=$S($P($G(^PSDRUG(+PSD,0)),"^")]"":$P(^(0),"^"),1:"ZZ/"_PSD_" NAME MISSING"),SLVL=+$P(NODE,"^",3),EXP=$S(+$P(NODE,"^",12):+$P(NODE,"^",12),1:"")
"RTN","PSDBALI",46,0)
 .I EXP S Y=EXP X ^DD("DD") S EXP=Y
"RTN","PSDBALI",47,0)
 .I ASKN D LOOP Q
"RTN","PSDBALI",48,0)
 .S ^TMP("PSDBALI",$J,DRUGN,PSD)=BAL_"^"_PSDOK_"^"_SLVL_"^"_EXP_"^"_$P($G(^PSDRUG(+PSD,0)),"^",3)
"RTN","PSDBALI",49,0)
PRINT ;prints data
"RTN","PSDBALI",50,0)
 S (PG,PSDOUT)=0 D NOW^%DTC S Y=+$E(%,1,12) X ^DD("DD") S RPDT=Y
"RTN","PSDBALI",51,0)
 K LN S $P(LN,"-",80)="" D HDR
"RTN","PSDBALI",52,0)
 I '$D(^TMP("PSDBALI",$J)) W !!,?15,"**** NO STOCK BALANCE DATA AVAILABLE ****",!! G DONE
"RTN","PSDBALI",53,0)
 I ASKN D PRINT^PSDBALI1 G DONE
"RTN","PSDBALI",54,0)
 S PSDR="" F  S PSDR=$O(^TMP("PSDBALI",$J,PSDR)) Q:PSDR=""!(PSDOUT)  F PSD=0:0 S PSD=$O(^TMP("PSDBALI",$J,PSDR,PSD)) Q:'PSD  D  Q:PSDOUT
"RTN","PSDBALI",55,0)
 .I $Y+6>IOSL W !,?10,"Inspector's Signature: ______________________________",! D HDR Q:PSDOUT
"RTN","PSDBALI",56,0)
 .S NODE=^TMP("PSDBALI",$J,PSDR,PSD),BAL=+NODE,PSDOK=$P(NODE,"^",2),SLVL=$P(NODE,"^",3),EXP=$P(NODE,"^",4)
"RTN","PSDBALI",57,0)
 .W !,PSDOK,?2,PSDR,?45,$J(BAL,6),?61,$$SCH^PSDBAL(+$P(NODE,"^",5)),?67,"___________",! W:SLVL ?5,"Stock Level: ",SLVL W:EXP]"" ?30,"Exp. Date: ",EXP W ! S LNUM=$Y
"RTN","PSDBALI",58,0)
PRT ;
"RTN","PSDBALI",59,0)
 I LNUM<IOSL-5 F JJ=LNUM:1:IOSL-5 W !
"RTN","PSDBALI",60,0)
 W:'PSDOUT ?10,"Inspector's Signature: ______________________________",!
"RTN","PSDBALI",61,0)
DONE I $E(IOST)'="C" W @IOF
"RTN","PSDBALI",62,0)
 I $E(IOST,1,2)="C-",'PSDOUT W ! K DIR,DIRUT S DIR(0)="EA",DIR("A")="END OF REPORT!  Press <RET> to return to the menu" D ^DIR K DIR
"RTN","PSDBALI",63,0)
END ;
"RTN","PSDBALI",64,0)
 K %,%H,%I,%ZIS,ALL,ASKN,BAL,C,DA,DIC,DRUGN,DTOUT,DUOUT,EXP,JJ,LN,LNUM,NODE,PG,POP,PSD,PSDEV,PSDOK,PSDOUT,PSDR,PSDRN,PSDS,PSDSN,RPDT,SLVL,TYP,TYPN,X,Y
"RTN","PSDBALI",65,0)
 K ^TMP("PSDBALI",$J),ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK,DEA,SCH
"RTN","PSDBALI",66,0)
 D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
"RTN","PSDBALI",67,0)
 Q
"RTN","PSDBALI",68,0)
SAVE S (ZTSAVE("PSDS"),ZTSAVE("PSDSN"),ZTSAVE("PSDSITE"),ZTSAVE("ASKN"),ZTSAVE("SCH"),ZTSAVE("SCH("))=""
"RTN","PSDBALI",69,0)
 S:$D(ALL) ZTSAVE("ALL")="" S:$D(PSDR) ZTSAVE("PSDR(")=""
"RTN","PSDBALI",70,0)
 Q
"RTN","PSDBALI",71,0)
HDR ;header
"RTN","PSDBALI",72,0)
 I $E(IOST,1,2)="C-",PG K DA,DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSDOUT=1 Q
"RTN","PSDBALI",73,0)
 S PG=PG+1 W:$Y @IOF W !,?12,"Inventory Sheet for ",PSDSN,?72,"Page: ",PG,!,?20,$S(SCH=1:"Schedules I - II",SCH=2:"Schedules III - V",SCH=3:"Schedules I - V",1:""),!?20,RPDT,!!
"RTN","PSDBALI",74,0)
 W ?5,"DRUG",?41,"CURRENT BALANCE",?58,"SCHEDULE",?69,"ON-HAND",!,LN,!!
"RTN","PSDBALI",75,0)
 Q
"RTN","PSDBALI",76,0)
LOOP ;sets inv type
"RTN","PSDBALI",77,0)
 I '$O(^PSD(58.8,+PSDS,1,+PSD,2,0)) S TYPN="ZZ** NO INVENTORY TYPE DATA **" D LOOP1
"RTN","PSDBALI",78,0)
 F TYP=0:0 S TYP=$O(^PSD(58.8,+PSDS,1,+PSD,2,TYP)) Q:'TYP  S TYPN=$S($P($G(^PSI(58.16,+TYP,0)),"^")]"":$P(^(0),"^"),1:"TYPE NAME MISSING") D LOOP1
"RTN","PSDBALI",79,0)
 Q
"RTN","PSDBALI",80,0)
LOOP1 S ^TMP("PSDBALI",$J,TYPN,DRUGN,PSD)=BAL_"^"_PSDOK_"^"_SLVL_"^"_EXP_"^"_$P($G(^PSDRUG(+PSD,0)),"^",3)
"RTN","PSDBALI",81,0)
 Q
"RTN","PSDBALI1")
0^11^B5019533^B4606716
"RTN","PSDBALI1",1,0)
PSDBALI1 ;BIR/JPW-Display/Prt Drug Inv Sheet & Bal (cont'd) ; 12 Apr 94
"RTN","PSDBALI1",2,0)
 ;;3.0;CONTROLLED SUBSTANCES;**73**;13 Feb 97;Build 8
"RTN","PSDBALI1",3,0)
PRINT ;prints data
"RTN","PSDBALI1",4,0)
 S TYPN="" F  S TYPN=$O(^TMP("PSDBALI",$J,TYPN)) Q:TYPN=""!(PSDOUT)  W !,?2,"=> INVENTORY TYPE: ",$S($E(TYPN,1,2)="ZZ":$E(TYPN,3,99),1:TYPN),! D
"RTN","PSDBALI1",5,0)
 .S PSDR="" F  S PSDR=$O(^TMP("PSDBALI",$J,TYPN,PSDR)) Q:PSDR=""!(PSDOUT)  F PSD=0:0 S PSD=$O(^TMP("PSDBALI",$J,TYPN,PSDR,PSD)) Q:'PSD  D  Q:PSDOUT
"RTN","PSDBALI1",6,0)
 ..I $Y+6>IOSL W !,?10,"Inspector's Signature: ______________________________",! D HDR Q:PSDOUT  W !,?2,"=> INVENTORY TYPE: ",$S($E(TYPN,1,2)="ZZ":$E(TYPN,3,99),1:TYPN),!
"RTN","PSDBALI1",7,0)
 ..S NODE=^TMP("PSDBALI",$J,TYPN,PSDR,PSD),BAL=+NODE,PSDOK=$P(NODE,"^",2),SLVL=$P(NODE,"^",3),EXP=$P(NODE,"^",4)
"RTN","PSDBALI1",8,0)
 ..W !,PSDOK,?2,PSDR,?45,$J(BAL,6),?61,$$SCH^PSDBAL(+$P(NODE,"^",5)),?67,"___________",! W:SLVL ?5,"Stock Level: ",SLVL W:EXP]"" ?30,"Exp. Date: ",EXP W ! S LNUM=$Y
"RTN","PSDBALI1",9,0)
PRT ;
"RTN","PSDBALI1",10,0)
 I LNUM<IOSL-5 F JJ=LNUM:1:IOSL-5 W !
"RTN","PSDBALI1",11,0)
 W:'PSDOUT ?10,"Inspector's Signature: ______________________________",!
"RTN","PSDBALI1",12,0)
 Q
"RTN","PSDBALI1",13,0)
HDR ;header
"RTN","PSDBALI1",14,0)
 I $E(IOST,1,2)="C-",PG K DA,DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSDOUT=1 Q
"RTN","PSDBALI1",15,0)
 S PG=PG+1 W:$Y @IOF W !,?12,"Inventory Sheet for ",PSDSN,?72,"Page: ",PG,!,?20,RPDT,!!
"RTN","PSDBALI1",16,0)
 W ?5,"DRUG",?41,"CURRENT BALANCE",?58,"SCHEDULE",?69,"ON-HAND",!,LN,!!
"RTN","PSDBALI1",17,0)
 Q
"RTN","PSDDSOR")
0^1^B86052358^B76244326
"RTN","PSDDSOR",1,0)
PSDDSOR ;BHM/MHA/PWC - Digitally signed CS Orders Report; 08/30/02
"RTN","PSDDSOR",2,0)
 ;;3.0;CONTROLLED SUBSTANCES;**40,42,45,67,73**;Feb 13,1997;Build 8
"RTN","PSDDSOR",3,0)
 ;Ref. to ^PSRX( supp. by IA 1977
"RTN","PSDDSOR",4,0)
 ;Ref. to ^PS(52.41, supp. by IA 3848
"RTN","PSDDSOR",5,0)
 ;Ref. to ^PS(59, supp. by IA 2621
"RTN","PSDDSOR",6,0)
 ;Ref. ^PSDRUG( supp. by IA 2621
"RTN","PSDDSOR",7,0)
 ;Ref. to GETDATA^ORWOR1 supp. by IA 3750
"RTN","PSDDSOR",8,0)
 ;
"RTN","PSDDSOR",9,0)
 N AC,BDT,CT,DFN,DP,DRG,DRUG,DV,DVN,EDT,FI,NS,OP,ORD,ORS,PAT,PG,POS,PL,PL1,PRO,PROV
"RTN","PSDDSOR",10,0)
 N PSDBD,PSDDF,PSDDV,PSDED,PSDIO,PSDPO,PSDPR,PSDPT,PSDRG,PSDSC,PSDSD
"RTN","PSDDSOR",11,0)
 N PSDXF,RX,RX0,RX2,S1,S2,S3,S4,S5,S6,SCH,SR,SRT,TDT,TY,I,J,O,X,Y,Z
"RTN","PSDDSOR",12,0)
 I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE)
"RTN","PSDDSOR",13,0)
SITE I '$D(PSOSITE) D  Q:$D(DUOUT)!($D(DTOUT))  G:'$D(PSOSITE) SITE
"RTN","PSDDSOR",14,0)
 .W ! S DIC("A")="Division: ",DIC=59,DIC(0)="AEMQ"
"RTN","PSDDSOR",15,0)
 .S DIC("S")="I $S('$D(^PS(59,+Y,""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0)"
"RTN","PSDDSOR",16,0)
 .D ^DIC K DIC Q:$D(DUOUT)!($D(DTOUT))  I +Y>0 S PSOSITE=+Y Q
"RTN","PSDDSOR",17,0)
 .W !!,"A 'DIVISION' must be selected!  or Enter '^' to exit."
"RTN","PSDDSOR",18,0)
 S PSDDV=PSOSITE
"RTN","PSDDSOR",19,0)
 W !!?10,"You are logged on under the ",$P(^PS(59,PSDDV,0),"^")," division.",!
"RTN","PSDDSOR",20,0)
DATE ;ask date range
"RTN","PSDDSOR",21,0)
 W ! K %DT S %DT(0)=-DT,%DT="AEP",%DT("A")="Start Date: " D ^%DT
"RTN","PSDDSOR",22,0)
 I Y<0!($D(DTOUT)) G END
"RTN","PSDDSOR",23,0)
 S (%DT(0),PSDBD)=Y,%DT("A")="End Date: "
"RTN","PSDDSOR",24,0)
 W ! D ^%DT I Y<0!($D(DTOUT)) G END
"RTN","PSDDSOR",25,0)
 S PSDED=Y,PSDSD=PSDBD-.000001
"RTN","PSDDSOR",26,0)
 W ! D KV S DIR("A")="Include discontinued orders",DIR(0)="Y",DIR("B")="NO"
"RTN","PSDDSOR",27,0)
 D ^DIR K DIR G:$D(DIRUT) END S PSDDF=Y
"RTN","PSDDSOR",28,0)
 W ! S DIR("A")="Include expired orders",DIR(0)="Y",DIR("B")="NO" D ^DIR
"RTN","PSDDSOR",29,0)
 K DIR G:$D(DIRUT) END S PSDXF=Y
"RTN","PSDDSOR",30,0)
 I $G(PSDCSRX) S PSDPO="N" G SL
"RTN","PSDDSOR",31,0)
 W ! S DIR("A")="Include pending orders",DIR(0)="Y",DIR("B")="NO" D ^DIR
"RTN","PSDDSOR",32,0)
 K DIR G:$D(DIRUT) END S PSDPO=Y
"RTN","PSDDSOR",33,0)
SL S (CT,PSDRG,PSDPR,PSDPT,PSDSC)=1,DP="Within ",DIR("B")="Drug" K SRT,SR
"RTN","PSDDSOR",34,0)
 S OP="D:Drug;PR:Provider;PA:Patient;S:Schedule"
"RTN","PSDDSOR",35,0)
 F  D KV S DIR(0)="SAO^"_OP D  Q:OP=""!($D(DUOUT))!($D(DTOUT))!($D(DIRUT))
"RTN","PSDDSOR",36,0)
 .S:CT=1 DIR("B")="Drug" K:CT>1 DIR("B")
"RTN","PSDDSOR",37,0)
 .S DIR("A")=$S(CT>1:DP,1:"")_"Sort By: " D ^DIR
"RTN","PSDDSOR",38,0)
 .Q:$D(DIRUT)
"RTN","PSDDSOR",39,0)
 .I Y="S" S PSDSC=0
"RTN","PSDDSOR",40,0)
 .S O="" F I=1:1:$L(OP,";") S J=$P(OP,";",I) I J'[Y(0) S O=O_$S(O="":"",1:";")_J
"RTN","PSDDSOR",41,0)
 .S OP=O
"RTN","PSDDSOR",42,0)
 .S SRT(CT)=Y,SR(Y)=CT S CT=CT+1,DP=DP_$S(Y="D":"Drug, ",Y="PR":"Provider, ",Y="PA":"Patient, ",1:"Schedule, ")
"RTN","PSDDSOR",43,0)
 .D @Y
"RTN","PSDDSOR",44,0)
 G:$D(DUOUT)!($D(DTOUT)) END
"RTN","PSDDSOR",45,0)
 I $D(SRT) K SR S I="" D  G:$D(DIRUT) END G:'Y SL
"RTN","PSDDSOR",46,0)
 .W !!,"You have selected the following:",!
"RTN","PSDDSOR",47,0)
 .F  S I=$O(SRT(I)) Q:I=""  D
"RTN","PSDDSOR",48,0)
 ..S J=SRT(I),SR(I)=$S(J="D":"DRUG",J="PR":"PROV",J="PA":"PAT",1:"SCH")
"RTN","PSDDSOR",49,0)
 ..W !?5,$S(J="D":"Drug",J="PR":"Provider",J="PA":"Patient",1:"Schedule")
"RTN","PSDDSOR",50,0)
 .W ! D KV S DIR("A")="Continue to print:",DIR("B")="Y",DIR(0)="YN" D ^DIR
"RTN","PSDDSOR",51,0)
 G DEV Q
"RTN","PSDDSOR",52,0)
D ;ask drug(s)
"RTN","PSDDSOR",53,0)
 W !!,?5,"You may select a single drug, several drugs,",!,?5,"or enter ^ALL to select all drugs.",!!
"RTN","PSDDSOR",54,0)
 K DRG,DIC S PSDRG=0,DIC("A")="Select DRUG: ",DIC=50,DIC(0)="QEAM"
"RTN","PSDDSOR",55,0)
 S DIC("S")="I $S('$D(^(""I"")):1,'^(""I""):1,DT'>+^(""I""):1,1:0),$P($G(^(2)),""^"",3)[""O"",$D(^PSDRUG(""ASP"",+$G(^(2)),+Y)),+$P(^PSDRUG(+Y,0),""^"",3)&(+$P(^PSDRUG(+Y,0),""^"",3)<6)"
"RTN","PSDDSOR",56,0)
 F  D ^DIC Q:Y<0  S DRG(+Y)=""
"RTN","PSDDSOR",57,0)
 S X=$$UP^XLFSTR(X)  ; PSD*3*67 pwc
"RTN","PSDDSOR",58,0)
 K DIC I X="^ALL" S PSDRG=1 K DUOUT Q
"RTN","PSDDSOR",59,0)
 Q:($D(DUOUT))!($D(DTOUT))
"RTN","PSDDSOR",60,0)
 I '$D(DRG)&(Y<0) G D
"RTN","PSDDSOR",61,0)
 Q
"RTN","PSDDSOR",62,0)
PR ;ask provider(s)
"RTN","PSDDSOR",63,0)
 W !!,?5,"You may select a single provider, several providers,",!,?5,"or enter ^ALL to select all providers.",!!
"RTN","PSDDSOR",64,0)
 K PRO,DIC S PSDPR=0,DIC="^VA(200,",DIC(0)="QEAM",DIC("A")="Select Provider: "
"RTN","PSDDSOR",65,0)
 F  D ^DIC Q:Y<0  S PRO(+Y)=""
"RTN","PSDDSOR",66,0)
 S X=$$UP^XLFSTR(X)  ; PSD*3*67 PWC
"RTN","PSDDSOR",67,0)
 K DIC I X="^ALL" S PSDPR=1 K DUOUT Q
"RTN","PSDDSOR",68,0)
 Q:$D(DUOUT)!($D(DTOUT))
"RTN","PSDDSOR",69,0)
 I '$D(PRO)&(Y<0) G PR
"RTN","PSDDSOR",70,0)
 Q
"RTN","PSDDSOR",71,0)
PA ;ask patient(s)
"RTN","PSDDSOR",72,0)
 W !!,?5,"You may select a single patient, several patients,",!,?5,"or enter ^ALL to select all patients.",!!
"RTN","PSDDSOR",73,0)
 K PAT,DIC S PSDPT=0,DIC=2,DIC(0)="QEAM",DIC("A")="Select Patient: "
"RTN","PSDDSOR",74,0)
 F  D ^DIC Q:Y<0  S PAT(+Y)=""
"RTN","PSDDSOR",75,0)
 S X=$$UP^XLFSTR(X)  ; PSD*3*67 pwc
"RTN","PSDDSOR",76,0)
 K DIC I X="^ALL" S PSDPT=1 K DUOUT Q
"RTN","PSDDSOR",77,0)
 Q:$D(DUOUT)!($D(DTOUT))
"RTN","PSDDSOR",78,0)
 I '$D(PAT)&(Y<0) G PA
"RTN","PSDDSOR",79,0)
 Q
"RTN","PSDDSOR",80,0)
S ;
"RTN","PSDDSOR",81,0)
 W !!,"Select controlled substance schedule(s)"
"RTN","PSDDSOR",82,0)
 K DIR
"RTN","PSDDSOR",83,0)
 S DIR(0)="S^1:"_$S($G(PSDCSRX):"SCHEDULE I - II",1:"SCHEDULE II")_";2:SCHEDULES III - V;3:SCHEDULES II - V",DIR("A")="Select Schedule(s)",DIR("B")=3
"RTN","PSDDSOR",84,0)
 D ^DIR I $D(DTOUT)!($D(DUOUT))!($D(DIRUT)) Q
"RTN","PSDDSOR",85,0)
 K SCH S I=$S($G(PSDCSRX)&(Y=1):1,Y=2:3,1:2),J=$S(Y=1:2,1:5) F K=I:1:J S SCH(K)=""
"RTN","PSDDSOR",86,0)
 W ! D KV
"RTN","PSDDSOR",87,0)
 Q
"RTN","PSDDSOR",88,0)
DEV K %ZIS,IOP,POP,ZTSK S PSDIO=ION,%ZIS="QM" D ^%ZIS K %ZIS
"RTN","PSDDSOR",89,0)
 I POP S IOP=PSDIO D ^%ZIS K IOP,PSDIO W !,"Please try later!" G END
"RTN","PSDDSOR",90,0)
 K PSDIO I $D(IO("Q")) K IO("Q"),ZTIO,ZTSAVE,ZTDTH,ZTSK D  G END
"RTN","PSDDSOR",91,0)
 .S ZTRTN="EN^PSDDSOR",ZTDESC="Digitally Signed CS Orders Report"
"RTN","PSDDSOR",92,0)
 .F G="PSOSITE","PSDDV","PSDSD","PSDBD","PSDED","PSDDF","PSDXF","PSDPO","PSDRG","PSDPR","PSDPT","PSDSC" S:$D(@G) ZTSAVE(G)=""
"RTN","PSDDSOR",93,0)
 .S ZTSAVE("SRT(")="",ZTSAVE("SR(")="" S:$D(PRO) ZTSAVE("PRO(")="" S:$D(DRG) ZTSAVE("DRG(")="" S:$D(PAT) ZTSAVE("PAT(")="" S:$D(SCH) ZTSAVE("SCH(")=""
"RTN","PSDDSOR",94,0)
 .D ^%ZTLOAD W:$D(ZTSK) !,"Report is Queued to print !!" K ZTSK
"RTN","PSDDSOR",95,0)
EN ;
"RTN","PSDDSOR",96,0)
 K ^TMP($J) S (I,NS)=0 F  S I=$O(SR(I)) Q:'I  S NS=I
"RTN","PSDDSOR",97,0)
 S PND=0,TY="APKI",POS=PSDSD F  S PSDSD=$O(^PSRX(TY,PSDSD)) Q:'PSDSD!(PSDSD>PSDED)  D EN1
"RTN","PSDDSOR",98,0)
 D:PSDPO EN2 D PSTR G END
"RTN","PSDDSOR",99,0)
 Q
"RTN","PSDDSOR",100,0)
EN1 S RX=0 F  S RX=$O(^PSRX(TY,PSDSD,RX)) Q:'RX  D
"RTN","PSDDSOR",101,0)
 .Q:'$D(^PSRX(RX,0))  Q:$P(^(2),"^",9)'=PSDDV  Q:($G(PSDCSRX))&('+$P(^(2),"^",2))  S RX0=^(0),ORD=$P($G(^("OR1")),"^",2)
"RTN","PSDDSOR",102,0)
 .Q:'$P(RX0,"^",2)!('$P(RX0,"^",4))!('$P(RX0,"^",6))!('ORD)
"RTN","PSDDSOR",103,0)
 .D GETD
"RTN","PSDDSOR",104,0)
 Q
"RTN","PSDDSOR",105,0)
EN2 S DV=0,FI=52.41,PND=1
"RTN","PSDDSOR",106,0)
 N PSIR,PSINST
"RTN","PSDDSOR",107,0)
 S PSIR=0 F  S PSIR=$O(^PS(59,PSOSITE,"INI1",PSIR)) Q:'PSIR  I $P($G(^PS(59,PSOSITE,"INI1",PSIR,0)),"^") S PSINST($P($G(^(0)),"^"))=""
"RTN","PSDDSOR",108,0)
 F  S POS=$O(^PS(FI,TY,POS)) Q:'POS!(POS>(PSDED_".999999"))  S DV=0 F  S DV=$O(^PS(FI,TY,POS,DV)) Q:'DV  D
"RTN","PSDDSOR",109,0)
 .S RX=0 F  S RX=$O(^PS(FI,TY,POS,DV,RX)) Q:'RX  D
"RTN","PSDDSOR",110,0)
 ..Q:'$D(^PS(FI,RX,0))  S RX0=^(0)
"RTN","PSDDSOR",111,0)
 ..I $P(RX0,"^",3)["NW"!($P(RX0,"^",3)="DC") I $P(RX0,"^",24),$D(PSINST($P($G(^PS(52.41,RX,"INI")),"^"))) S ORD=$P(RX0,"^") D GETD
"RTN","PSDDSOR",112,0)
 Q
"RTN","PSDDSOR",113,0)
GETD ;
"RTN","PSDDSOR",114,0)
 I $G(PSDPT) G GETD1
"RTN","PSDDSOR",115,0)
 Q:'$D(PAT($P(RX0,"^",2)))
"RTN","PSDDSOR",116,0)
GETD1 ;
"RTN","PSDDSOR",117,0)
 D GETDATA^PSDDSOR1(.Y,ORD,$P(RX0,"^",2)) Q:Y<0  D:$G(PND) 
"RTN","PSDDSOR",118,0)
 .S Y=Y_"^"_$P(RX0,"^",3)
"RTN","PSDDSOR",119,0)
 .I $P(RX0,"^",3)="DC",$G(^PS(52.41,RX,4))]"" D
"RTN","PSDDSOR",120,0)
 ..S Y=Y_"^"_$TR(^PS(52.41,RX,4),":",","),$P(Y,"^",4)="13;DISCONTINUED"
"RTN","PSDDSOR",121,0)
 D CONT
"RTN","PSDDSOR",122,0)
 Q
"RTN","PSDDSOR",123,0)
CONT ;
"RTN","PSDDSOR",124,0)
 S ORS=+$P(Y,"^",4) Q:ORS=""  S $P(Y,"^",12)=$S($G(PND):"P",1:"R")
"RTN","PSDDSOR",125,0)
 S $P(Y,"^",13)=$S($G(PND):$P(RX0,"^",13),1:$P(RX0,"^",5))
"RTN","PSDDSOR",126,0)
 I '$P(Y,"^",10) Q:'PSDXF&(ORS=7)  Q:'PSDDF&(",1,12,13,"[(","_ORS_","))  S S1=$S(ORS=5:4,ORS=7:3,",1,12,13,"[(","_ORS_","):2,1:1)
"RTN","PSDDSOR",127,0)
 I $P(Y,"^",10) Q:'PSDXF&(ORS=11)  Q:'PSDDF&(",12,13,14,15,"[(","_ORS_","))  S S1=$S(ORS=99:4,ORS=11:3,",12,13,14,15,"[(","_ORS_","):2,1:1)
"RTN","PSDDSOR",128,0)
 S PAT=$P($G(Y(1)),"^") Q:PAT=""
"RTN","PSDDSOR",129,0)
 S DRUG=$S($P($G(Y(2)),"^")]"":$P(Y(2),"^"),$P($G(Y(6)),"^")]"":$P(Y(6),"^"),1:"")
"RTN","PSDDSOR",130,0)
 N DRGN S DRGN=$S(+$P($G(Y(2)),"^",2):+$P(Y(2),"^",2),+$P($G(Y(6)),"^",2):+$P(Y(6),"^",2),1:"")
"RTN","PSDDSOR",131,0)
 G:$G(PSDRG) CT1
"RTN","PSDDSOR",132,0)
 Q:'$D(DRG(DRGN))
"RTN","PSDDSOR",133,0)
CT1 S PROV=$P($G(Y(4)),"^") Q:PROV=""
"RTN","PSDDSOR",134,0)
 G:$G(PSDPR) CT2
"RTN","PSDDSOR",135,0)
 Q:'$D(PRO($P(Y(4),"^",2)))
"RTN","PSDDSOR",136,0)
CT2 S SCH=$P($G(Y(2)),"^",5) Q:SCH=""  ; check is this the DEA code?
"RTN","PSDDSOR",137,0)
 G:$G(PSDSC) CT3
"RTN","PSDDSOR",138,0)
 Q:'$D(SCH(+$P(Y(2),"^",5)))  ;if schedule not selected then should include all schedules.
"RTN","PSDDSOR",139,0)
CT3 I NS=4 D  Q
"RTN","PSDDSOR",140,0)
 .S ^TMP($J,S1,@(SR(1)),@(SR(2)),@(SR(3)),@(SR(4)),RX,0)=Y,I=0
"RTN","PSDDSOR",141,0)
 .F  S I=$O(Y(I)) Q:'I  M ^TMP($J,S1,@(SR(1)),@(SR(2)),@(SR(3)),@(SR(4)),RX,I)=Y(I)
"RTN","PSDDSOR",142,0)
 I NS=3 D  Q
"RTN","PSDDSOR",143,0)
 .S ^TMP($J,S1,@(SR(1)),@(SR(2)),@(SR(3)),RX,0)=Y,I=0
"RTN","PSDDSOR",144,0)
 .F  S I=$O(Y(I)) Q:'I  M ^TMP($J,S1,@(SR(1)),@(SR(2)),@(SR(3)),RX,I)=Y(I)
"RTN","PSDDSOR",145,0)
 I NS=2 D  Q
"RTN","PSDDSOR",146,0)
 .S ^TMP($J,S1,@(SR(1)),@(SR(2)),RX,0)=Y,I=0
"RTN","PSDDSOR",147,0)
 .F  S I=$O(Y(I)) Q:'I  M ^TMP($J,S1,@(SR(1)),@(SR(2)),RX,I)=Y(I)
"RTN","PSDDSOR",148,0)
 S ^TMP($J,S1,@(SR(1)),RX,0)=Y,I=0
"RTN","PSDDSOR",149,0)
 F  S I=$O(Y(I)) Q:'I  M ^TMP($J,S1,@(SR(1)),RX,I)=Y(I)
"RTN","PSDDSOR",150,0)
 Q
"RTN","PSDDSOR",151,0)
 ;
"RTN","PSDDSOR",152,0)
PSTR D NOW^%DTC S TDT=$E(%,4,5)_"/"_$E(%,6,7)_"/"_$E(%,2,3)_"@"_$E(%,9,10)_":"_$E(%,11,12)
"RTN","PSDDSOR",153,0)
 N P1,P2 S $E(P1,42)="",$E(P2,12)="",PG=1,Y=PSDBD D D^DIQ S BDT=Y,Y=PSDED D D^DIQ S EDT=Y
"RTN","PSDDSOR",154,0)
 S DVN=$$GET1^DIQ(59,PSDDV,.01) S:DVN]"" DVN=$E(DVN,1,20) S:DVN="" DVN="N/A"
"RTN","PSDDSOR",155,0)
 U IO I '$D(^TMP($J)) D HD W !!,"**********    NO DATA TO PRINT   **********",!! Q
"RTN","PSDDSOR",156,0)
 D @("N"_NS)
"RTN","PSDDSOR",157,0)
 Q
"RTN","PSDDSOR",158,0)
IN K Y0,Y1,Y2,Y3,Y4,Y5,Y6 S S6=""
"RTN","PSDDSOR",159,0)
 Q
"RTN","PSDDSOR",160,0)
WR S PG=1 D HD W !,$S(AC=1:"Processed",AC=2:"Discontinued",AC=3:"Expired",1:"Pending")_" Orders:",! Q
"RTN","PSDDSOR",161,0)
N4 S AC="" F  S AC=$O(^TMP($J,AC)) Q:'AC  D WR D  Q:$D(DIRUT)  D HD1 Q:$D(DIRUT)
"RTN","PSDDSOR",162,0)
 .S S1="" F  S S1=$O(^TMP($J,AC,S1)) Q:S1=""  S S2="" F  S S2=$O(^TMP($J,AC,S1,S2)) Q:S2=""  D  Q:$D(DIRUT)
"RTN","PSDDSOR",163,0)
 ..S S3="" F  S S3=$O(^TMP($J,AC,S1,S2,S3)) Q:S3=""  S S4="" F  S S4=$O(^TMP($J,AC,S1,S2,S3,S4)) Q:S4=""  D  Q:$D(DIRUT)
"RTN","PSDDSOR",164,0)
 ...S S5="" F  S S5=$O(^TMP($J,AC,S1,S2,S3,S4,S5)) Q:S5=""  D STR4 Q:$D(DIRUT)
"RTN","PSDDSOR",165,0)
 Q
"RTN","PSDDSOR",166,0)
STR4 ;
"RTN","PSDDSOR",167,0)
 D IN F  S S6=$O(^TMP($J,AC,S1,S2,S3,S4,S5,S6)) Q:S6=""  S Z="Y"_S6,@Z=^TMP($J,AC,S1,S2,S3,S4,S5,S6)
"RTN","PSDDSOR",168,0)
 D PRT Q
"RTN","PSDDSOR",169,0)
N3 S AC="" F  S AC=$O(^TMP($J,AC)) Q:'AC  D WR D  Q:$D(DIRUT)  D HD1 Q:$D(DIRUT)
"RTN","PSDDSOR",170,0)
 .S S1="" F  S S1=$O(^TMP($J,AC,S1)) Q:S1=""  S S2="" F  S S2=$O(^TMP($J,AC,S1,S2)) Q:S2=""  D  Q:$D(DIRUT)
"RTN","PSDDSOR",171,0)
 ..S S3="" F  S S3=$O(^TMP($J,AC,S1,S2,S3)) Q:S3=""  D  Q:$D(DIRUT)
"RTN","PSDDSOR",172,0)
 ...S S5="" F  S S5=$O(^TMP($J,AC,S1,S2,S3,S5)) Q:S5=""  D STR3 Q:$D(DIRUT)
"RTN","PSDDSOR",173,0)
 Q
"RTN","PSDDSOR",174,0)
STR3 D IN F  S S6=$O(^TMP($J,AC,S1,S2,S3,S5,S6)) Q:S6=""  S Z="Y"_S6 M @Z=^TMP($J,AC,S1,S2,S3,S5,S6)
"RTN","PSDDSOR",175,0)
 D PRT Q
"RTN","PSDDSOR",176,0)
N2 S AC="" F  S AC=$O(^TMP($J,AC)) Q:'AC  D WR D  Q:$D(DIRUT)  D HD1 Q:$D(DIRUT)
"RTN","PSDDSOR",177,0)
 .S S1="" F  S S1=$O(^TMP($J,AC,S1)) Q:S1=""  S S2="" F  S S2=$O(^TMP($J,AC,S1,S2)) Q:S2=""  D  Q:$D(DIRUT)
"RTN","PSDDSOR",178,0)
 ..S S5="" F  S S5=$O(^TMP($J,AC,S1,S2,S5)) Q:S5=""  D STR2 Q:$D(DIRUT)
"RTN","PSDDSOR",179,0)
 Q
"RTN","PSDDSOR",180,0)
STR2 D IN F  S S6=$O(^TMP($J,AC,S1,S2,S5,S6)) Q:S6=""  S Z="Y"_S6 M @Z=^TMP($J,AC,S1,S2,S5,S6)
"RTN","PSDDSOR",181,0)
 D PRT Q
"RTN","PSDDSOR",182,0)
N1 S AC="" F  S AC=$O(^TMP($J,AC)) Q:'AC  D WR D  Q:$D(DIRUT)  D HD1 Q:$D(DIRUT)
"RTN","PSDDSOR",183,0)
 .S S1="" F  S S1=$O(^TMP($J,AC,S1)) Q:S1=""  D  Q:$D(DIRUT)
"RTN","PSDDSOR",184,0)
 ..S S5="" F  S S5=$O(^TMP($J,AC,S1,S5)) Q:S5=""  D STR1 Q:$D(DIRUT)
"RTN","PSDDSOR",185,0)
 Q
"RTN","PSDDSOR",186,0)
STR1 D IN F  S S6=$O(^TMP($J,AC,S1,S5,S6)) Q:S6=""  S Z="Y"_S6 M @Z=^TMP($J,AC,S1,S5,S6)
"RTN","PSDDSOR",187,0)
 D PRT
"RTN","PSDDSOR",188,0)
 Q
"RTN","PSDDSOR",189,0)
PRT D:($Y+4)>IOSL HD Q:$D(DIRUT)  D PRT^PSDDSOR1
"RTN","PSDDSOR",190,0)
 Q
"RTN","PSDDSOR",191,0)
HD D HD1 Q:$D(DIRUT)
"RTN","PSDDSOR",192,0)
 W @IOF,!?2,"Digitally Signed CS Orders Report for Division "_DVN,?70,"Page: ",PG
"RTN","PSDDSOR",193,0)
 W !,?8,"Date Range: "_BDT_" - "_EDT,?53,"Printed on: "_TDT,!
"RTN","PSDDSOR",194,0)
 S PG=PG+1
"RTN","PSDDSOR",195,0)
 Q
"RTN","PSDDSOR",196,0)
HD1 I PG>1,$E(IOST)="C" K DIR S DIR(0)="E",DIR("A")=" Press Return to Continue or ^ to Exit" D ^DIR K DIR
"RTN","PSDDSOR",197,0)
 Q
"RTN","PSDDSOR",198,0)
END W ! D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
"RTN","PSDDSOR",199,0)
 K ^TMP($J),PSDDV,PSDSD,PSDED,PSDDF,PSDXF,DRG,PRO,PAT,PND,SCH,SRT,PSDRG,PSDPR,PSDPT,PSDSC,VA,Y0,Y1,Y2,Y3,Y4,Y5,Y6,I,J,K,PSDCSRX
"RTN","PSDDSOR",200,0)
KV K DIR,DIRUT,DTOUT,DUOUT
"RTN","PSDDSOR",201,0)
 Q
"RTN","PSDDSOR",202,0)
 ;
"RTN","PSDDSOR",203,0)
INST ;
"RTN","PSDDSOR",204,0)
 N PSIR
"RTN","PSDDSOR",205,0)
 S PSIR=0 F  S PSIR=$O(^PS(59,PSOSITE,"INI1",PSIR)) Q:'PSIR  I $P($G(^PS(59,PSOSITE,"INI1",PSIR,0)),"^") S PSINST($P($G(^(0)),"^"))=""
"RTN","PSDDSOR",206,0)
 Q
"RTN","PSDDSOR1")
0^2^B31741433^B9308208
"RTN","PSDDSOR1",1,0)
PSDDSOR1 ;BHM/MHA/PWC - Digitally signed CS Orders Report; 08/30/02
"RTN","PSDDSOR1",2,0)
 ;;3.0;CONTROLLED SUBSTANCES;**40,67,73**;Feb 13,1997;Build 8
"RTN","PSDDSOR1",3,0)
 ;Ref. to ^PSRX( supported by DBIA 1977
"RTN","PSDDSOR1",4,0)
 ;Ref. to ^PS(52.41, supported by DBIA 3848
"RTN","PSDDSOR1",5,0)
 ;
"RTN","PSDDSOR1",6,0)
 Q
"RTN","PSDDSOR1",7,0)
PRT I ($Y+13)>IOSL D:AC HD^PSDDSOR D:'AC HD^PSDDSOR2 Q:$D(DIRUT)
"RTN","PSDDSOR1",8,0)
 S I=0,PL=""
"RTN","PSDDSOR1",9,0)
 I $P($G(Y2),"^")]"" S PL=$E($P(Y2,"^"),1,30)
"RTN","PSDDSOR1",10,0)
 E  S PL=$E($P($G(Y6),"^"),1,30),I=1
"RTN","PSDDSOR1",11,0)
 W !?1," DRUG"_$S($G(I):" (OI)",1:"")_": "_PL,?50,"CS Federal Schedule: "_+$P(Y2,"^",5)
"RTN","PSDDSOR1",12,0)
 F I=1:1 Q:'$G(Y7(I))  W "       ",Y7(I),!
"RTN","PSDDSOR1",13,0)
 W !?2,"Provider: "_$E($P(Y4,"^")_P1,1,30),?50,"DEA #: "_$P(Y4,"^",3)
"RTN","PSDDSOR1",14,0)
 W !?2,"Clinic: "_$$GET1^DIQ(44,$P(Y0,"^",13),.01),?50,"Detox #: "_$P(Y4,"^",4)
"RTN","PSDDSOR1",15,0)
 S PL=$P(Y5,"^"),PL1="" F I=2:1:6 S J=$P(Y5,"^",I) D:J]""
"RTN","PSDDSOR1",16,0)
 .I PL1="",$L(J)+$L(PL)<60 S PL=PL_", "_J
"RTN","PSDDSOR1",17,0)
 .E  S PL1=PL1_$S(PL1]"":", ",1:"")_J
"RTN","PSDDSOR1",18,0)
 W !?2,"Provider Address: "_PL W:PL1]"" !?20,PL1
"RTN","PSDDSOR1",19,0)
 W !?2,"CPRS Order #: "_$P(Y0,"^",2),?50,"Date Order Written: " S Y=$P(Y0,"^",5) I Y W $E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)
"RTN","PSDDSOR1",20,0)
 W !?2,"Patient Name: "_$E($P(Y1,"^")_P1,1,30),?50,"PATIENT ID: "
"RTN","PSDDSOR1",21,0)
 S DFN=$S($P(Y0,"^",12)="R":$P(^PSRX(S5,0),"^",2),1:$P($G(^PS(52.41,S5,0)),"^",2)) D PID^VADPT W $E($P(Y1,"^"))_VA("BID")
"RTN","PSDDSOR1",22,0)
 S PL=$P(Y1,"^",2),PL1="" F I=3:1:7 S J=$P(Y1,"^",I) D:J]""
"RTN","PSDDSOR1",23,0)
 .I PL1="",$L(J)+$L(PL)<60 S PL=PL_", "_J
"RTN","PSDDSOR1",24,0)
 .E  S PL1=PL1_$S(PL1]"":", ",1:"")_J
"RTN","PSDDSOR1",25,0)
 W !?2,"Patient Address: "_PL W:PL1]"" !?19,PL1
"RTN","PSDDSOR1",26,0)
 W !?2,"Rx #: "_$S($P(Y0,"^",12)="R":$P(^PSRX(S5,0),"^"),1:"")
"RTN","PSDDSOR1",27,0)
 W ?50,"Qty: "_$S(AC=4:$P(^PS(52.41,S5,0),"^",10),1:$P(Y2,"^",3))
"RTN","PSDDSOR1",28,0)
 W !?2,"SIG: "
"RTN","PSDDSOR1",29,0)
 D FSIG($P(Y0,"^",12),S5,75)
"RTN","PSDDSOR1",30,0)
 I $G(FSIG(1))'="" D
"RTN","PSDDSOR1",31,0)
 . W $$UNESC^ORHLESC($G(FSIG(1)))
"RTN","PSDDSOR1",32,0)
 . I $O(FSIG(1)) D
"RTN","PSDDSOR1",33,0)
 . . F EE=1:0 S EE=$O(FSIG(EE)) Q:'EE  D
"RTN","PSDDSOR1",34,0)
 . . . W !?6,$$UNESC^ORHLESC($G(FSIG(EE)))
"RTN","PSDDSOR1",35,0)
 F  S PL=$O(Y3(PL)) Q:'PL  W ?7,Y3(PL),!
"RTN","PSDDSOR1",36,0)
P1 S RX2=$S($P(Y0,"^",12)="R":$G(^PSRX(S5,2)),1:"")
"RTN","PSDDSOR1",37,0)
 W !?2,"Date Filled: ",$$FMTE^XLFDT($P(RX2,"^",2),2)
"RTN","PSDDSOR1",38,0)
 W ?27,"# of Refills: ",$S($P(Y0,"^",12)="R":+$P($G(^PSRX(S5,0)),"^",9),1:$P($G(^PS(52.41,S5,0)),"^",11))
"RTN","PSDDSOR1",39,0)
 W ?50,"Date Released: " S Y=$P(RX2,"^",13) I Y W $E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)
"RTN","PSDDSOR1",40,0)
 W !?2,"Releasing Pharmacist: "_$S($P(RX2,"^",3):$P(^VA(200,$P(RX2,"^",3),0),"^"),1:"")
"RTN","PSDDSOR1",41,0)
 W ?50,"Valid PKI Certificate?: "
"RTN","PSDDSOR1",42,0)
 N FL0 S FL0=$S(AC=4:"No",1:"Yes"),Y=$P(RX2,"^",2)
"RTN","PSDDSOR1",43,0)
 I $P(Y0,"^",12)="R",AC'=4,$D(^PSRX(S5,"A")) N FL S FL=0 F  S FL=$O(^PSRX(S5,"A",FL)) Q:'FL!(FL0="No")  I $P(^PSRX(S5,"A",FL,0),"^",2)="K" S FL0="No",Y=$P($P(^(0),"^"),".")
"RTN","PSDDSOR1",44,0)
 W FL0
"RTN","PSDDSOR1",45,0)
 W !?2,"Date Signature Validation Attempted by Pharmacy: "
"RTN","PSDDSOR1",46,0)
 I Y W $E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)
"RTN","PSDDSOR1",47,0)
 W !?2,"CPRS Nature of Order: "_$P(Y0,"^",3),?50,"Order Status: "_$P($P(Y0,"^",4),";",2)
"RTN","PSDDSOR1",48,0)
 S PL=$S($P(Y0,"^",7)]"":$P(Y0,"^",7),$P(Y0,"^"):"Digitally Signed",1:"")
"RTN","PSDDSOR1",49,0)
 W !?2,"Signature Status: "_$E(PL,1,60) W:$L(PL)>60 !,?20,$E(PL,61,200) W !
"RTN","PSDDSOR1",50,0)
 Q
"RTN","PSDDSOR1",51,0)
 ;
"RTN","PSDDSOR1",52,0)
GETDATA(Y,ORIEN,DFN) ;Gets data from archival file, otherwise use old CPRS call.
"RTN","PSDDSOR1",53,0)
 ;Input: ORIEN  - Order IEN
"RTN","PSDDSOR1",54,0)
 ;       DFN    - Patient IEN
"RTN","PSDDSOR1",55,0)
 ;Output Y
"RTN","PSDDSOR1",56,0)
 ;On error: Y = -1^Error message
"RTN","PSDDSOR1",57,0)
 ;Else: Y = 1^ Order # ^ Nature of order ^ Order Status ^ Date Signed
"RTN","PSDDSOR1",58,0)
 ;   Y(1) = "Patient name ^ Street1 ^ Street2 ^ Street3 ^ City ^ State ^ Zip"
"RTN","PSDDSOR1",59,0)
 ;   Y(2) = "Drug name_strength_dosage form (Dispense drug) ^ Drug IEN (file 50) ^ Drug quantity prescribed ^ Schedule of medication ^5 DEA Schedule"
"RTN","PSDDSOR1",60,0)
 ;   Y(3) = "Directions for use (SIG)"
"RTN","PSDDSOR1",61,0)
 ;   Y(4) = "Provider's name ^ DUZ ^ Provider's DEA # ^ Provider's DETOX #"
"RTN","PSDDSOR1",62,0)
 ;   Y(5) = "SiteName ^ SiteStreet1  ^ SiteStreet2 ^ SiteCity  ^ SiteState ^ SiteZip"
"RTN","PSDDSOR1",63,0)
 ;   Y(6) = "Orderable Item ^ Orderable Item IEN (file 50.7)"
"RTN","PSDDSOR1",64,0)
 ;   Y(7) = "Strenght ^ Dosage Form
"RTN","PSDDSOR1",65,0)
 N TMP,PND0,RX0,DDR
"RTN","PSDDSOR1",66,0)
 I $G(ORIEN)="" S Y="-1^INVALID ORDER #" Q
"RTN","PSDDSOR1",67,0)
 I $G(DFN)="" S Y="-1^INVALID PATIENT ID" Q
"RTN","PSDDSOR1",68,0)
 K ^TMP($J,"ORDEA")
"RTN","PSDDSOR1",69,0)
 D ARCHIVE^ORDEA(ORIEN)
"RTN","PSDDSOR1",70,0)
 I $D(^TMP($J,"ORDEA",ORIEN,1)),'$P(^(1),"^"),'$G(PND) N NCHK S NCHK=0 D  I 'NCHK S Y="-1^INVALID PRESCRIPTION #" Q
"RTN","PSDDSOR1",71,0)
 . S NCHK=$$SUBSCRIB^ORDEA(ORIEN,RX)
"RTN","PSDDSOR1",72,0)
 . I NCHK K ^TMP($J,"ORDEA") D ARCHIVE^ORDEA(ORIEN)
"RTN","PSDDSOR1",73,0)
 I '$D(^TMP($J,"ORDEA")) D GETDATA^ORWOR1(.Y,ORIEN,DFN) Q
"RTN","PSDDSOR1",74,0)
 F I=1:1:5 S TMP(I)=$G(^TMP($J,"ORDEA",ORIEN,I))
"RTN","PSDDSOR1",75,0)
 I DFN'=$P(TMP(4),"^",2) S Y="-1^INVALID PATIENT ID" Q
"RTN","PSDDSOR1",76,0)
 S RXIEN=$O(^PSRX("APL",ORIEN,"")),RX0=$S(RXIEN:$G(^PSRX(RXIEN,0)),1:""),RXOI=$S(RXIEN:$G(^PSRX(RXIEN,"OR1")),1:"")
"RTN","PSDDSOR1",77,0)
 S PIEN=$O(^PS(52.41,"B",ORIEN,"")),PND0=$S(PIEN:$G(^PS(52.41,PIEN,0)),1:"")
"RTN","PSDDSOR1",78,0)
 I RXIEN="",PIEN="" S Y="-1^INVALID ORDER #" Q
"RTN","PSDDSOR1",79,0)
 I RXIEN'="",RXIEN'=$P(TMP(1),"^") S Y="-1^INVALID PRESCRIPTION #" Q
"RTN","PSDDSOR1",80,0)
 I RXIEN,'$P($G(^PSRX(RXIEN,"PKI")),"^") S Y="-1^ORDER HAS NOT BEEN DIGITALLY SIGNED" Q
"RTN","PSDDSOR1",81,0)
 I PIEN,'$P(PND0,"^",24) S Y="-1^ORDER HAS NOT BEEN DIGITALLY SIGNED" Q
"RTN","PSDDSOR1",82,0)
 S DDR=$P(RX0,"^",6) S:DDR DDR=$$GET1^DIQ(50,DDR,.01)_"^"_DDR
"RTN","PSDDSOR1",83,0)
 S STA=$S(RXIEN:$P($G(^PSRX(RXIEN,"STA")),"^")_";"_$$GET1^DIQ(52,RXIEN,100),1:99_";"_$$GET1^DIQ(52.41,PIEN,2))
"RTN","PSDDSOR1",84,0)
 S Y="1^"_ORIEN_"^ELECTRONICALLY ENTERED^"_STA_"^"_$P(TMP(1),"^",2)
"RTN","PSDDSOR1",85,0)
 S Y(1)=$P(TMP(4),"^")_"^"_TMP(5)
"RTN","PSDDSOR1",86,0)
 S Y(2)=$S($P(TMP(1),"^",3)'="":$P(TMP(1),"^",3,4),DDR'="":DDR,1:"^")_"^"_$P(TMP(1),"^",6)_"^^"_$P(TMP(1),"^",5)
"RTN","PSDDSOR1",87,0)
 S Y(3)="" M Y(3)=TMP(6)
"RTN","PSDDSOR1",88,0)
 S Y(4)=$P(TMP(2),"^",3)_"^"_$P(TMP(2),"^",4)_"^"_$P(TMP(2),"^",1,2)
"RTN","PSDDSOR1",89,0)
 S Y(5)=TMP(3)
"RTN","PSDDSOR1",90,0)
 S ORI=$S($P(RXOI,"^"):$P(RXOI,"^"),1:$P(PND0,"^",8))
"RTN","PSDDSOR1",91,0)
 S ORIE=$S($D(^PS(50.7,ORI,0)):$P(^PS(50.7,ORI,0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^"),1:"")
"RTN","PSDDSOR1",92,0)
 S Y(6)=ORIE_"^"_ORI
"RTN","PSDDSOR1",93,0)
 S CN=$O(TMP(7,"")) I CN'="" S $P(Y(2),"^")=$P(Y(2),"^")_" "_$TR(TMP(7,CN),"^"," ")
"RTN","PSDDSOR1",94,0)
 S Y(7)="" M Y(7)=TMP(7) I CN'="" K Y(7,CN)
"RTN","PSDDSOR1",95,0)
 S $P(Y,"^",10)=1
"RTN","PSDDSOR1",96,0)
 Q
"RTN","PSDDSOR1",97,0)
 ;
"RTN","PSDDSOR1",98,0)
FSIG(PSOFILE,PSOINTR,PSOLENTH) ;Format front door sig
"RTN","PSDDSOR1",99,0)
 ;PSOFILE is 'P' if in Pending File, 'R' if in Prescription File
"RTN","PSDDSOR1",100,0)
 ;PSOINTR is internal number for either file
"RTN","PSDDSOR1",101,0)
 ;PSOLENTH is length of each line of the Sig
"RTN","PSDDSOR1",102,0)
 ;returned in the FSIG array
"RTN","PSDDSOR1",103,0)
 K FSIG I $G(PSOFILE)=""!('$G(PSOINTR))!('$G(PSOLENTH)) G FQUIT
"RTN","PSDDSOR1",104,0)
 I PSOFILE'="P",PSOFILE'="R" G FQUIT
"RTN","PSDDSOR1",105,0)
 I PSOFILE="P",'$D(^PS(52.41,+PSOINTR,0)) G FQUIT
"RTN","PSDDSOR1",106,0)
 I PSOFILE="R",'$D(^PSRX(+PSOINTR,0)) G FQUIT
"RTN","PSDDSOR1",107,0)
 I PSOFILE="R",'$P($G(^PSRX(+PSOINTR,"SIG")),"^",2) G FQUIT
"RTN","PSDDSOR1",108,0)
 N FFF,NNN,CNT,FVAR,FVAR1,FLIM,HSIG,II
"RTN","PSDDSOR1",109,0)
 I PSOFILE="P" F NNN=0:0 S NNN=$O(^PS(52.41,PSOINTR,"SIG",NNN)) Q:'NNN  S:$G(^(NNN,0))'="" HSIG(NNN)=^(0)
"RTN","PSDDSOR1",110,0)
 I PSOFILE="P" G:'$O(HSIG(0)) FQUIT G FSTART
"RTN","PSDDSOR1",111,0)
 S FFF=1 F NNN=0:0 S NNN=$O(^PSRX(PSOINTR,"SIG1",NNN)) Q:'NNN  I $G(^(NNN,0))'="" S HSIG(FFF)=^(0) S FFF=FFF+1
"RTN","PSDDSOR1",112,0)
 G:'$O(HSIG(0)) FQUIT
"RTN","PSDDSOR1",113,0)
FSTART S (FVAR,FVAR1)="",II=1
"RTN","PSDDSOR1",114,0)
 F FFF=0:0 S FFF=$O(HSIG(FFF)) Q:'FFF  S CNT=0 F NNN=1:1:$L(HSIG(FFF)) I $E(HSIG(FFF),NNN)=" "!($L(HSIG(FFF))=NNN) S CNT=CNT+1 D  I $L(FVAR)>PSOLENTH S FSIG(II)=FLIM_" ",II=II+1,FVAR=FVAR1
"RTN","PSDDSOR1",115,0)
 .S FVAR1=$P(HSIG(FFF)," ",(CNT))
"RTN","PSDDSOR1",116,0)
 .S FLIM=FVAR
"RTN","PSDDSOR1",117,0)
 .S FVAR=$S(FVAR="":FVAR1,1:FVAR_" "_FVAR1)
"RTN","PSDDSOR1",118,0)
 I $G(FVAR)'="" S FSIG(II)=FVAR
"RTN","PSDDSOR1",119,0)
 I $G(FSIG(1))=""!($G(FSIG(1))=" ") S FSIG(1)=$G(FSIG(2)) K FSIG(2)
"RTN","PSDDSOR1",120,0)
FQUIT Q
"RTN","PSDDSOR2")
0^3^B23181227^B21366672
"RTN","PSDDSOR2",1,0)
PSDDSOR2 ;BIR/MHA-Digitally Signed OP Released Rx Report; 05/09/03
"RTN","PSDDSOR2",2,0)
 ;;3.0;CONTROLLED SUBSTANCES;**40,42,45,73**;Feb 13,1997;Build 8
"RTN","PSDDSOR2",3,0)
 ;Ref. ^PSD(58.8 supp. by IA 2711
"RTN","PSDDSOR2",4,0)
 ;Ref. ^PSD(58.81 supp. by IA 2808
"RTN","PSDDSOR2",5,0)
 ;Ref. ^PSRX( supp. by IA 1977
"RTN","PSDDSOR2",6,0)
 ;Ref. ^PS(59 supp. by IA 2621
"RTN","PSDDSOR2",7,0)
 ;Ref. ^PSDRUG( supp. by IA 2621
"RTN","PSDDSOR2",8,0)
BEG I '$D(PSDSITE) D ^PSDSET G:'$D(PSDSITE) END
"RTN","PSDDSOR2",9,0)
 N PSDV,PSDL,PSDLN,PSDB,PSDS,PSDE,PSDRG,DRG
"RTN","PSDDSOR2",10,0)
 D DT^DICRW
"RTN","PSDDSOR2",11,0)
 S PSDL=$P(PSDSITE,U,3),PSDLN=$P(PSDSITE,U,4)
"RTN","PSDDSOR2",12,0)
 S DIC="^PSD(58.8,",DIC(0)="AEQ",DIC("A")="Select Dispensing Site: "
"RTN","PSDDSOR2",13,0)
 S DIC("S")="I $P($G(^(0)),U,3)=+PSDSITE,$S($P($G(^(0)),U,2)[""M"":1,$P($G(^(0)),U,2)[""S"":1,1:0),($S('$D(^(""I"")):1,+^(""I"")>DT:1,'^(""I""):1,1:0))"
"RTN","PSDDSOR2",14,0)
 S DIC("B")=$P(PSDSITE,U,4)
"RTN","PSDDSOR2",15,0)
 W ! D ^DIC K DIC G:Y<0 END
"RTN","PSDDSOR2",16,0)
 S $P(PSDSITE,U,3)=+Y,PSDL=+Y,$P(PSDSITE,U,4)=$P(Y,U,2),PSDLN=$P(Y,U,2),PSDV=PSDSITE
"RTN","PSDDSOR2",17,0)
 W ! K %DT S %DT(0)=-DT,%DT="AEP",%DT("A")="Start Date: " D ^%DT
"RTN","PSDDSOR2",18,0)
 G:Y<0 END
"RTN","PSDDSOR2",19,0)
 S (%DT(0),PSDB)=Y,%DT("A")="End Date: "
"RTN","PSDDSOR2",20,0)
 W ! D ^%DT G:Y<0 END
"RTN","PSDDSOR2",21,0)
 S PSDE=Y,PSDS=PSDB-.000001
"RTN","PSDDSOR2",22,0)
D ;ask schedule(s)
"RTN","PSDDSOR2",23,0)
 W !!,"Select a schedule(s)"
"RTN","PSDDSOR2",24,0)
 K DIR
"RTN","PSDDSOR2",25,0)
 S DIR(0)="S^1:SCHEDULE II;2:SCHEDULES III - V;3:SCHEDULES II - V",DIR("A")="Select Schedule(s)",DIR("B")=3
"RTN","PSDDSOR2",26,0)
 D ^DIR I $D(DTOUT)!($D(DUOUT))!($D(DIRUT)) Q
"RTN","PSDDSOR2",27,0)
 K SCH S I=$S(Y=2:3,1:2),J=$S(Y=1:2,1:5) F K=I:1:J S SCH(K)=""
"RTN","PSDDSOR2",28,0)
 W ! K DIR,X,Y,I,J,K
"RTN","PSDDSOR2",29,0)
DEV K %ZIS,IOP,POP,ZTSK S PSDIO=ION,%ZIS="QM" D ^%ZIS K %ZIS
"RTN","PSDDSOR2",30,0)
 I POP S IOP=PSDIO D ^%ZIS K IOP,PSDIO W !,"Please try later!" G END
"RTN","PSDDSOR2",31,0)
 K PSDIO I $D(IO("Q")) K IO("Q"),ZTIO,ZTSAVE,ZTDTH,ZTSK D  G END
"RTN","PSDDSOR2",32,0)
 .S ZTRTN="EN^PSDDSOR2",ZTDESC="Digitally Signed OP Released Rx Report"
"RTN","PSDDSOR2",33,0)
 .F G="PSDL","PSDLN","PSDV","PSDS","PSDB","PSDE","PSDRG" S:$D(@G) ZTSAVE(G)="" S ZTSAVE("SCH(")=""
"RTN","PSDDSOR2",34,0)
 .S:$D(DRG) ZTSAVE("DRG(")=""
"RTN","PSDDSOR2",35,0)
 .D ^%ZTLOAD W:$D(ZTSK) !,"Report is Queued to print !!" K ZTSK
"RTN","PSDDSOR2",36,0)
EN ;
"RTN","PSDDSOR2",37,0)
 K ^TMP($J)
"RTN","PSDDSOR2",38,0)
 N RX,RX0,RX2,ORD,DR,TDT,BDT,EDT,DFN,PL,PL1,P1,P2,PG,AC,S1,S2,S5,S6,Y0,Y1,Y2,Y3,Y4,Y5,Y6
"RTN","PSDDSOR2",39,0)
 N ST,STD,PR,DRN,DV,DVD,I,J,Z,RC,DEA,TRXTYPE,NODE6,FILL,DDR
"RTN","PSDDSOR2",40,0)
 ;
"RTN","PSDDSOR2",41,0)
 S TRXTYPE=+$O(^PSD(58.84,"B","OUTPATIENT RX",0)),RC=0
"RTN","PSDDSOR2",42,0)
 F  S PSDS=$O(^PSD(58.81,"AF",PSDS)) Q:'PSDS!(PSDS>(PSDE_".99999"))  D
"RTN","PSDDSOR2",43,0)
 . S RC=0 F  S RC=$O(^PSD(58.81,"AF",PSDS,+PSDL,TRXTYPE,RC)) Q:'RC  D
"RTN","PSDDSOR2",44,0)
 . . S NODE6=$G(^PSD(58.81,RC,6)),RX=+$P(NODE6,"^",1),FILL=+$P(NODE6,"^",2)
"RTN","PSDDSOR2",45,0)
 . . I '$G(RX)!'$P($G(^PSRX(RX,"PKI")),"^") Q
"RTN","PSDDSOR2",46,0)
 . . I '$$RXRLDT^PSOBPSUT(RX,FILL) Q
"RTN","PSDDSOR2",47,0)
 . . S RX0=$G(^PSRX(RX,0)),DR=$P(RX0,"^",6)
"RTN","PSDDSOR2",48,0)
 . . Q:DR'=$P(^PSD(58.81,RC,0),U,5)  S DEA=+$P($G(^PSDRUG(DR,0)),"^",3),DDR=$P($G(^PSDRUG(DR,0)),"^")
"RTN","PSDDSOR2",49,0)
 . . D:$D(SCH(DEA)) GD
"RTN","PSDDSOR2",50,0)
 ;
"RTN","PSDDSOR2",51,0)
 D NOW^%DTC S TDT=$E(%,4,5)_"/"_$E(%,6,7)_"/"_$E(%,2,3)_"@"_$E(%,9,10)_":"_$E(%,11,12)
"RTN","PSDDSOR2",52,0)
 S AC=0,$E(P1,42)="",$E(P2,12)="",PG=1,Y=PSDB D D^DIQ S BDT=Y,Y=PSDE D D^DIQ S EDT=Y
"RTN","PSDDSOR2",53,0)
 U IO D HD I '$D(^TMP($J)) W !!,"**********    NO DATA TO PRINT   **********",!! G END
"RTN","PSDDSOR2",54,0)
 D PRD
"RTN","PSDDSOR2",55,0)
END ;
"RTN","PSDDSOR2",56,0)
 W ! D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
"RTN","PSDDSOR2",57,0)
 K ^TMP($J)
"RTN","PSDDSOR2",58,0)
 Q
"RTN","PSDDSOR2",59,0)
GD ;
"RTN","PSDDSOR2",60,0)
 S DFN=$P(RX0,U,2),RX2=^PSRX(RX,2),PR=$P(RX0,U,4),ORD=$P($G(^("OR1")),U,2),ST=+$P($G(^("STA")),U) Q:'+$P($G(^("PKI")),U)
"RTN","PSDDSOR2",61,0)
 Q:'DFN!('PR)!('DR)!('ORD)
"RTN","PSDDSOR2",62,0)
 S STD=$P("ERROR^ACTIVE^NON-VERIFIED^REFILL FILL^HOLD^NON-VERIFIED^SUSPENDED^^^^^DONE^EXPIRED^DISCONTINUED^DISCONTINUED^DISCONTINUED^DISCONTINUED(EDIT)^HOLD^","^",ST+2)
"RTN","PSDDSOR2",63,0)
 S ST=ST_";"_STD
"RTN","PSDDSOR2",64,0)
 ;D ARCHIVE^ORDEA(ORD)
"RTN","PSDDSOR2",65,0)
 ;I $D(^TMP($J,"ORDEA")) D  Q
"RTN","PSDDSOR2",66,0)
 ;.F I=1:1:5 S TMP(I)=$G(^TMP($J,"ORDEA",ORD,I))
"RTN","PSDDSOR2",67,0)
 ;.S DRN=$S($P(TMP(1),"^",3)'="":$P(TMP(1),"^",3),$G(DDR)'="":DDR,1:"UNKNOWN DRUG")
"RTN","PSDDSOR2",68,0)
 ;.S ^TMP($J,PSDS,DRN,RX,0)="1"_U_ORD_U_U_ST_U_$P(TMP(1),U,2)_U_U_U_U_U_U_U_"R"
"RTN","PSDDSOR2",69,0)
 ;.S ^TMP($J,PSDS,DRN,RX,1)=$P(TMP(4),U)_U_TMP(5)
"RTN","PSDDSOR2",70,0)
 ;.S ^TMP($J,PSDS,DRN,RX,2)=DRN_U_DR_U_$P(TMP(1),U,4)_U_U_$P($G(^PSDRUG(DR,0)),U,3)
"RTN","PSDDSOR2",71,0)
 ;.S ^TMP($J,PSDS,DRN,RX,3)=""
"RTN","PSDDSOR2",72,0)
 ;.S ^TMP($J,PSDS,DRN,RX,4)=$P(TMP(2),U,3)_U_PR_U_$P(TMP(2),U,1,2)
"RTN","PSDDSOR2",73,0)
 ;.S ^TMP($J,PSDS,DRN,RX,5)=TMP(5)
"RTN","PSDDSOR2",74,0)
 S DRN=$S($G(DDR)'="":DDR,1:"UNKNOWN DRUG")
"RTN","PSDDSOR2",75,0)
 D ADD^VADPT
"RTN","PSDDSOR2",76,0)
 S ^TMP($J,PSDS,DRN,RX,0)="1"_U_ORD_U_U_ST_U_$P(RX2,U)_U_U_U_U_U_U_U_"R"
"RTN","PSDDSOR2",77,0)
 S ^TMP($J,PSDS,DRN,RX,1)=$P(^DPT(DFN,0),U)_U_VAPA(1)_U_VAPA(2)_U_VAPA(3)_U_VAPA(4)_U_$P(VAPA(5),U,2)_U_VAPA(6)
"RTN","PSDDSOR2",78,0)
 S ^TMP($J,PSDS,DRN,RX,2)=DRN_U_DR_U_$P(RX0,U,7)_U_U_$P($G(^PSDRUG(DR,0)),U,3)
"RTN","PSDDSOR2",79,0)
 S ^TMP($J,PSDS,DRN,RX,3)=""
"RTN","PSDDSOR2",80,0)
 S ^TMP($J,PSDS,DRN,RX,4)=$P($G(^VA(200,PR,0)),U)_U_PR_U_$$DEA^XUSER(0,PR)_U_$$DETOX^XUSER(PR)
"RTN","PSDDSOR2",81,0)
 S DV=+$P(RX2,U,9),DVD=$G(^PS(59,DV,0))
"RTN","PSDDSOR2",82,0)
 N ZIP S ZIP=$P(DVD,"^",5),ZIP=$S(ZIP["-":ZIP,1:$E(ZIP,1,5)_$S($E(ZIP,6,9)]"":"-"_$E(ZIP,6,9),1:""))
"RTN","PSDDSOR2",83,0)
 S ^TMP($J,PSDS,DRN,RX,5)=$P(DVD,U,1,2)_U_U_$P(DVD,U,7)_U_$P(^DIC(5,+$P(DVD,U,8),0),U)_U_ZIP
"RTN","PSDDSOR2",84,0)
 Q
"RTN","PSDDSOR2",85,0)
PRD S S1=0 F  S S1=$O(^TMP($J,S1)) Q:'S1  D  Q:$D(DIRUT)
"RTN","PSDDSOR2",86,0)
 .S S2="" F  S S2=$O(^TMP($J,S1,S2)) Q:S2=""  D  Q:$D(DIRUT)
"RTN","PSDDSOR2",87,0)
 ..S S5=0 F  S S5=$O(^TMP($J,S1,S2,S5)) Q:'S5  D PR  Q:$D(DIRUT)
"RTN","PSDDSOR2",88,0)
 Q
"RTN","PSDDSOR2",89,0)
PR K Y0,Y1,Y2,Y3,Y4,Y5,Y6 S S6=""
"RTN","PSDDSOR2",90,0)
 F  S S6=$O(^TMP($J,S1,S2,S5,S6)) Q:S6=""  S Z="Y"_S6,@Z=^TMP($J,S1,S2,S5,S6)
"RTN","PSDDSOR2",91,0)
 D:($Y+4)>IOSL HD Q:$D(DIRUT)  S Y6="" D PRT^PSDDSOR1
"RTN","PSDDSOR2",92,0)
 Q
"RTN","PSDDSOR2",93,0)
HD D HD1 Q:$D(DIRUT)
"RTN","PSDDSOR2",94,0)
 W @IOF,!,"Digitally Signed OP Released Rx Report for Vault "_$E(PSDLN,1,21),?71,"Page: ",PG
"RTN","PSDDSOR2",95,0)
 W !,?8,"Date Range: "_BDT_" - "_EDT,?53,"Printed on: "_TDT,!
"RTN","PSDDSOR2",96,0)
 S PG=PG+1
"RTN","PSDDSOR2",97,0)
 Q
"RTN","PSDDSOR2",98,0)
HD1 I PG>1,$E(IOST)="C" K DIR S DIR(0)="E",DIR("A")=" Press Return to Continue or ^ to Exit" D ^DIR K DIR
"RTN","PSDDSOR2",99,0)
 Q
"RTN","PSDPLOG")
0^5^B19818011^B17283374
"RTN","PSDPLOG",1,0)
PSDPLOG ;BIR/BJW - CS Inspector's Log ;11 Feb 98
"RTN","PSDPLOG",2,0)
 ;;3.0;CONTROLLED SUBSTANCES;**8,73**;13 Feb 97;Build 8
"RTN","PSDPLOG",3,0)
 ;**Y2K compliance**,"P" added to date input string
"RTN","PSDPLOG",4,0)
 I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE)
"RTN","PSDPLOG",5,0)
 ;S OK=$S($D(^XUSEC("PSJ RPHARM",DUZ)):1,$D(^XUSEC("PSJ PHARM TECH",DUZ)):1,1:0) I 'OK W $C(7),!!,?9,"** Please contact your Pharmacy Coordinator for access to",!,?12,"print the CS Inspector's Log.",! K OK Q
"RTN","PSDPLOG",6,0)
 W !,?5,"Inspector's Log for Active Green Sheets",!
"RTN","PSDPLOG",7,0)
RET ;ask to include returns
"RTN","PSDPLOG",8,0)
 K DA,DIR,DIRUT S DIR(0)="Y",DIR("B")="YES",DIR("A")="Include Returns to Stock"
"RTN","PSDPLOG",9,0)
 S DIR("?")="Answer 'YES' or return to include returns to stock, 'NO' to continue without returns, or '^' to quit."
"RTN","PSDPLOG",10,0)
 D ^DIR K DIR I $D(DIRUT) D MSG G END
"RTN","PSDPLOG",11,0)
 S PSDRET=+Y G:'PSDRET ASKN
"RTN","PSDPLOG",12,0)
RDATE ;ask return date
"RTN","PSDPLOG",13,0)
 W ! K %DT S %DT="AEP",%DT("A")="Start with Date Returned to Stock: " D ^%DT I Y<0 S PSDOUT=1 D MSG G END
"RTN","PSDPLOG",14,0)
 S PSDSD=Y,PSDSD=PSDSD-.0001
"RTN","PSDPLOG",15,0)
ASKN ;ask naou or group
"RTN","PSDPLOG",16,0)
 W !!,?5,"Select one of the following:",!!,?10,"N",?20,"NAOU (One, Some, or ^ALL)",!,?10,"G",?20,"Group of NAOUs",!
"RTN","PSDPLOG",17,0)
 K DA,DIR,DIRUT S DIR(0)="SOA^N:NAOU;G:Group of NAOUs",DIR("A")="Select Method: "
"RTN","PSDPLOG",18,0)
 S DIR("?",1)="Enter 'N' to select one, some or ^ALL NAOU(s),",DIR("?")="enter 'G' to select a group of NAOUs, or '^' to quit"
"RTN","PSDPLOG",19,0)
 D ^DIR K DIR G:$D(DIRUT) END S SEL=Y D NOW^%DTC S PSDT=X K DA,DIC S CNT=0
"RTN","PSDPLOG",20,0)
 I SEL="G" D GROUP G:'$D(PSDG) END G SCH
"RTN","PSDPLOG",21,0)
 F  S DIC=58.8,DIC("A")="Select NAOU: ",DIC(0)="QEA",DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$P(^(0),""^"",2)=""N"",'$P(^(0),""^"",7)" D ^DIC K DIC Q:Y<0  D
"RTN","PSDPLOG",22,0)
 .S NAOU(+Y)="",CNT=CNT+1
"RTN","PSDPLOG",23,0)
 I '$D(NAOU)&(X'="^ALL") G END
"RTN","PSDPLOG",24,0)
 S:X="^ALL" ALL=1
"RTN","PSDPLOG",25,0)
SCH ;ask schedule
"RTN","PSDPLOG",26,0)
 W !!,"All Controlled Substances or Selected Schedules?"
"RTN","PSDPLOG",27,0)
 K DIR
"RTN","PSDPLOG",28,0)
 S DIR(0)="S^1:SCHEDULES I - II;2:SCHEDULES III - V;3:SCHEDULES I - V",DIR("A")="Select Schedule(s)",DIR("B")=3
"RTN","PSDPLOG",29,0)
 D ^DIR
"RTN","PSDPLOG",30,0)
 I $D(DIRUT) G END
"RTN","PSDPLOG",31,0)
 K PSDSCH S I=$S(Y=2:3,1:1),J=$S(Y=1:2,1:5) F K=I:1:J S PSDSCH(K)=""
"RTN","PSDPLOG",32,0)
 K I,J,K
"RTN","PSDPLOG",33,0)
SORT ;asks sort
"RTN","PSDPLOG",34,0)
 W ! K DA,DIR,DIRUT S DIR(0)="YO",DIR("A")="Do you wish to sort by Inventory Type",DIR("B")="NO"
"RTN","PSDPLOG",35,0)
 S DIR("?")="Answer YES to sort drugs by Inventory Type, NO or <RET> to sort by drug."
"RTN","PSDPLOG",36,0)
 D ^DIR K DIR G:$D(DIRUT) END S ASKN=Y
"RTN","PSDPLOG",37,0)
SORT2 ;asks second sort
"RTN","PSDPLOG",38,0)
 K DA,DIR,DIRUT S DIR(0)="SO^D:DRUG/DISPENSING #S;N:NUMERIC DISPENSING #S"
"RTN","PSDPLOG",39,0)
 S DIR("A")="Select Print Order for Inspector's Log",DIR("?",1)="Select D to print Dispensing Number numerically by drug, within an NAOU,",DIR("?")="select N to print numerically within an NAOU, or '^' to quit."
"RTN","PSDPLOG",40,0)
 D ^DIR K DIR G:$D(DIRUT) END S ASK=Y
"RTN","PSDPLOG",41,0)
DEV ;ask device and queue info
"RTN","PSDPLOG",42,0)
 W !!,"This report is designed for a 132 column format.",!,"You may queue this report to print at a later time.",!!
"RTN","PSDPLOG",43,0)
 K %ZIS,IOP,IO("Q"),POP S %ZIS="QM",%ZIS("B")="" D ^%ZIS I POP W !,"NO DEVICE SELECTED OR REPORT PRINTED!" G END
"RTN","PSDPLOG",44,0)
 I $D(IO("Q")) K IO("Q") S PSDIO=ION_";"_IOST_";"_IOM_";"_IOSL,ZTIO="" K ZTSAVE,ZTDTH,ZTSK S ZTRTN="START^PSDPLOG1",ZTDESC="Compile Narcotic Inspector Log" D SAVE,^%ZTLOAD,HOME^%ZIS K ZTSK G END
"RTN","PSDPLOG",45,0)
 U IO G START^PSDPLOG1
"RTN","PSDPLOG",46,0)
END K %,%DT,%H,%I,%ZIS,ALL,ASK,ASKN,CNT,DA,DIC,DIE,DIR,DIROUT,DIRUT,DR,DTOUT,DUOUT,EXP,EXPD,JJ,NAOU,NODE,NODE3,NUM,PSDSCH
"RTN","PSDPLOG",47,0)
 K OK,PSD,PSDA,PSDDT,PSDG,PSDIO,PSDOK,PSDOUT,PSDN,PSDNA,PSDPT,PSDR,PSDRN,PSDRD,PSDRDT,PSDRET,PSDSD,PSDST,PSDT,PSDTR
"RTN","PSDPLOG",48,0)
 K QTY,SEL,STAT,STATN,TYP,TYPN,X,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
"RTN","PSDPLOG",49,0)
 K ^TMP("PSDLOG",$J) D ^%ZISC
"RTN","PSDPLOG",50,0)
 S:$D(ZTQUEUED) ZTREQ="@"
"RTN","PSDPLOG",51,0)
 Q
"RTN","PSDPLOG",52,0)
GROUP ;select group of naous
"RTN","PSDPLOG",53,0)
 K DA,DIC F  S DIC=58.2,DIC("A")="Select NAOU INVENTORY GROUP NAME: ",DIC(0)="QEA",DIC("S")="I $S($D(^PSI(58.2,""CS"",+Y)):1,1:0)" D ^DIC K DIC Q:Y<0  S PSDG(+Y)=""
"RTN","PSDPLOG",54,0)
 Q
"RTN","PSDPLOG",55,0)
SAVE S (ZTSAVE("PSDIO"),ZTSAVE("PSDT"),ZTSAVE("CNT"),ZTSAVE("PSDSITE"),ZTSAVE("ASK"),ZTSAVE("ASKN"))="",ZTSAVE("PSDSCH(")=""
"RTN","PSDPLOG",56,0)
 S:$D(PSDG) ZTSAVE("PSDG(")="" S:$D(NAOU) ZTSAVE("NAOU(")="" S:$D(ALL) ZTSAVE("ALL")=""
"RTN","PSDPLOG",57,0)
 S ZTSAVE("PSDRET")="" S:$D(PSDSD) ZTSAVE("PSDSD")=""
"RTN","PSDPLOG",58,0)
 Q
"RTN","PSDPLOG",59,0)
MSG W !!,"No action taken.",!!
"RTN","PSDPLOG",60,0)
 Q
"RTN","PSDPLOG1")
0^6^B25428029^B24167221
"RTN","PSDPLOG1",1,0)
PSDPLOG1 ;BIR/JPW,LTL - CS Inspector's Log (cont'd) ;31 May 95
"RTN","PSDPLOG1",2,0)
 ;;3.0;CONTROLLED SUBSTANCES;**22,28,73**;13 Feb 97;Build 8
"RTN","PSDPLOG1",3,0)
 ;
"RTN","PSDPLOG1",4,0)
 ;References to ^PSD(58.8, covered by DBIA2711
"RTN","PSDPLOG1",5,0)
 ;References to ^PSD(58.81 are covered by DBIA2808
"RTN","PSDPLOG1",6,0)
 ;References to ^PSDRUG( are covered by DBIA221
"RTN","PSDPLOG1",7,0)
 ;References to ^PSI(58.16 are covered by DBIA213
"RTN","PSDPLOG1",8,0)
 ;References to ^PSI(58.2( are covered by DBIA213
"RTN","PSDPLOG1",9,0)
 ;
"RTN","PSDPLOG1",10,0)
START ;compile data
"RTN","PSDPLOG1",11,0)
 K ^TMP("PSDLOG",$J) S (PSDCNT,PSDOUT)=0
"RTN","PSDPLOG1",12,0)
 I $D(PSDG) F PSD=0:0 S PSD=$O(PSDG(PSD)) Q:'PSD  F PSDN=0:0 S PSDN=$O(^PSI(58.2,PSD,3,PSDN)) Q:'PSDN  I $D(^PSD(58.8,PSDN,0)),'$P(^(0),"^",7),$P(^(0),"^",3)=+PSDSITE S NAOU(PSDN)="",CNT=CNT+1
"RTN","PSDPLOG1",13,0)
 I $D(ALL) F PSD=0:0 S PSD=$O(^PSD(58.8,PSD)) Q:'PSD  I $D(^PSD(58.8,PSD,0)),$P(^(0),"^",2)="N",$P(^(0),"^",3)=+PSDSITE,'$P(^(0),"^",7) S NAOU(+PSD)=""
"RTN","PSDPLOG1",14,0)
 F STAT=2.99:0 S STAT=$O(^PSD(58.8,"AC",STAT)) Q:('STAT)!(STAT>5)  F PSD=0:0 S PSD=$O(^PSD(58.8,"AC",STAT,PSD)) Q:'PSD  D LOOP
"RTN","PSDPLOG1",15,0)
 S STAT=10 F PSD=0:0 S PSD=$O(^PSD(58.8,"AC",STAT,PSD)) Q:'PSD  D LOOP
"RTN","PSDPLOG1",16,0)
 ;PSD*3*28 22JUN00 (DAVE BLOCKER) ;perpetual Inventory
"RTN","PSDPLOG1",17,0)
 S STAT=13 F PSD=0:0 S PSD=$O(^PSD(58.8,"AC",STAT,PSD)) Q:'PSD  I $P($G(^PSD(58.8,+PSD,2)),"^",5)'="" D LOOP
"RTN","PSDPLOG1",18,0)
 I $G(PSDRET) F PSDN=PSDSD:0 S PSDN=$O(^PSD(58.81,"ACT",PSDN)) Q:'PSDN!(PSDOUT)  F JJ=0:0 S JJ=$O(^PSD(58.81,"ACT",PSDN,JJ)) Q:'JJ!(PSDOUT)  D
"RTN","PSDPLOG1",19,0)
 .F PSDR=0:0 S PSDR=$O(^PSD(58.81,"ACT",PSDN,JJ,PSDR)) Q:'PSDR!(PSDOUT)  F PSDA=0:0 S PSDA=$O(^PSD(58.81,"ACT",PSDN,JJ,PSDR,3,PSDA)) Q:'PSDA!(PSDOUT)  S PSDOK="#" D
"RTN","PSDPLOG1",20,0)
 ..Q:'$D(^PSD(58.81,+PSDA,0))  S NODE=^PSD(58.81,PSDA,0),NODE3=$G(^(3))
"RTN","PSDPLOG1",21,0)
 ..S DEA=+$P($G(^PSDRUG(+PSDR,0)),"^",3) I '$D(PSDSCH(DEA)) Q
"RTN","PSDPLOG1",22,0)
 ..S PSDRN=$S($P($G(^PSDRUG(+PSDR,0)),"^")]"":$P(^(0),"^"),1:"ZZ"_PSDR)
"RTN","PSDPLOG1",23,0)
 ..S PSD=+$P(NODE,"^",18) Q:'$D(NAOU(PSD))
"RTN","PSDPLOG1",24,0)
 ..S PSDNA=$S($P($G(^PSD(58.8,+PSD,0)),"^")]"":$P(^(0),"^"),1:"ZZ/"_PSD)
"RTN","PSDPLOG1",25,0)
 ..S NUM=$S($P(NODE,"^",17)]"":$P(NODE,"^",17),1:"UNKNOWN"),QTY=+$P(NODE3,"^",2),EXP=$P(NODE,"^",15),EXPD="" I EXP S Y=EXP X ^DD("DD") S EXPD=Y
"RTN","PSDPLOG1",26,0)
 ..S Y=$E(PSDN,1,7) X ^DD("DD") S PSDDT=Y
"RTN","PSDPLOG1",27,0)
 ..D SET
"RTN","PSDPLOG1",28,0)
 G:$D(ZTQUEUED) PRTQUE
"RTN","PSDPLOG1",29,0)
 I ASKN G PRINT^PSDPLOG3 Q
"RTN","PSDPLOG1",30,0)
 G PRINT^PSDPLOG2
"RTN","PSDPLOG1",31,0)
 Q
"RTN","PSDPLOG1",32,0)
PRTQUE ;queues print after compile
"RTN","PSDPLOG1",33,0)
 K ZTSAVE,ZTIO S ZTIO=PSDIO,ZTRTN=$S(ASKN:"PRINT^PSDPLOG3",1:"PRINT^PSDPLOG2"),ZTDESC="Print Narcotic Inspector Log",ZTDTH=$H
"RTN","PSDPLOG1",34,0)
 S (ZTSAVE("^TMP(""PSDLOG"",$J,"),ZTSAVE("CNT"),ZTSAVE("ASK"),ZTSAVE("ASKN"))=""
"RTN","PSDPLOG1",35,0)
 D ^%ZTLOAD K ^TMP("PSDLOG",$J),ZTSK
"RTN","PSDPLOG1",36,0)
END K %,%DT,%H,%I,%ZIS,ALL,ASK,ASKN,CNT,DA,DIC,DIE,DIR,DIROUT,DIRUT,DR,DTOUT,DUOUT,EXP,EXPD,JJ,NAOU,NODE,NODE3,NUM,DEA,PSDSCH
"RTN","PSDPLOG1",37,0)
 K OK,PSD,PSDA,PSDCNT,PSDDT,PSDG,PSDIO,PSDOK,PSDOUT,PSDN,PSDNA,PSDPT,PSDR,PSDRN,PSDRD,PSDRDT,PSDRET,PSDSD,PSDST,PSDT,PSDTR
"RTN","PSDPLOG1",38,0)
 K QTY,SEL,STAT,STATN,TYP,TYPN,X,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
"RTN","PSDPLOG1",39,0)
 K ^TMP("PSDLOG",$J) D ^%ZISC
"RTN","PSDPLOG1",40,0)
 S:$D(ZTQUEUED) ZTREQ="@"
"RTN","PSDPLOG1",41,0)
 Q
"RTN","PSDPLOG1",42,0)
LOOP ;starts drug loop
"RTN","PSDPLOG1",43,0)
 N DEA
"RTN","PSDPLOG1",44,0)
 F PSDR=0:0 S PSDR=$O(^PSD(58.8,"AC",STAT,PSD,PSDR)) Q:'PSDR  D
"RTN","PSDPLOG1",45,0)
 .S DEA=+$P($G(^PSDRUG(PSDR,0)),"^",3) I '$D(PSDSCH(DEA)) Q
"RTN","PSDPLOG1",46,0)
 .F PSDA=0:0 S PSDA=$O(^PSD(58.8,"AC",STAT,PSD,PSDR,PSDA)) Q:'PSDA  I $D(^PSD(58.8,PSD,1,PSDR,3,PSDA,0)) S NODE=^PSD(58.8,PSD,1,PSDR,3,PSDA,0) D
"RTN","PSDPLOG1",47,0)
 ..;DAVE B (PSD*3*22) Check for matching ORDER STATUSs
"RTN","PSDPLOG1",48,0)
 ..;First check 58.8's order node for status inconsistency
"RTN","PSDPLOG1",49,0)
 ..S STAT1=$P(NODE,"^",11),STAT2=$P(NODE,"^",12)
"RTN","PSDPLOG1",50,0)
 ..I ($G(STAT1)=6)!($G(STAT1)=7)!($G(STAT1)=8)!($G(STAT1)=9)!($G(STAT1)=11)!($G(STAT1)=12) Q
"RTN","PSDPLOG1",51,0)
 ..I $G(STAT2)>0 Q
"RTN","PSDPLOG1",52,0)
 ..;Then check the transaction file for matching status.
"RTN","PSDPLOG1",53,0)
 ..Q:'$D(NAOU(PSD))  S PSDNA=$S($P($G(^PSD(58.8,+PSD,0)),"^")]"":$P(^(0),"^"),1:"ZZ/"_PSD)
"RTN","PSDPLOG1",54,0)
 ..S PSDOK=$S(STAT=3:"**",STAT=10:"*",1:""),PSDTR=$P(NODE,"^",17) I STAT=10 Q:$D(^PSD(58.81,"AE",PSDTR))
"RTN","PSDPLOG1",55,0)
 ..S PSDRN=$S($P($G(^PSDRUG(PSDR,0)),"^")]"":$P(^(0),"^"),1:"ZZ/"_PSDR),STAT1=+$P(NODE,"^",11),STATN=$S($P($G(^PSD(58.82,STAT1,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
"RTN","PSDPLOG1",56,0)
 ..S QTY=$P(NODE,"^",19),NUM=$S($P(NODE,"^",16)]"":$P(NODE,"^",16),1:"UNKNOWN"),EXP=$P(NODE,"^",10),EXPD="" I EXP S Y=EXP X ^DD("DD") S EXPD=Y
"RTN","PSDPLOG1",57,0)
 ..S PSDST=$P(NODE,"^",14),PSDDT="" I PSDST S Y=$E(PSDST,1,7) X ^DD("DD") S PSDDT=Y
"RTN","PSDPLOG1",58,0)
 ..D SET
"RTN","PSDPLOG1",59,0)
 Q
"RTN","PSDPLOG1",60,0)
SET ;sets ^tmp
"RTN","PSDPLOG1",61,0)
 S PSDCNT=PSDCNT+1
"RTN","PSDPLOG1",62,0)
 I ASKN D LOOP0 Q
"RTN","PSDPLOG1",63,0)
 S:ASK="D" ^TMP("PSDLOG",$J,PSDNA,PSDRN,NUM,PSDCNT)=QTY_"^"_PSDDT_"^"_EXPD_"^"_PSDOK_"^^"_PSDR
"RTN","PSDPLOG1",64,0)
 S:ASK="N" ^TMP("PSDLOG",$J,PSDNA,NUM,PSDRN,PSDCNT)=QTY_"^"_PSDDT_"^"_EXPD_"^"_PSDOK_"^^"_PSDR
"RTN","PSDPLOG1",65,0)
 Q
"RTN","PSDPLOG1",66,0)
LOOP0 ;sets sort for inventory type sort
"RTN","PSDPLOG1",67,0)
 I '$O(^PSD(58.8,PSD,1,PSDR,2,0)) S TYPN="ZZ** NO INVENTORY TYPE DATA **" D LOOP1 Q
"RTN","PSDPLOG1",68,0)
 ;F NAOU=0:0 S NAOU=$O(NAOU(NAOU)) Q:'NAOU  
"RTN","PSDPLOG1",69,0)
 F TYP=0:0 S TYP=$O(^PSD(58.8,+PSD,1,PSDR,2,TYP)) Q:'TYP  S TYPN=$S($P($G(^PSI(58.16,+TYP,0)),"^")]"":$P(^(0),"^"),1:"TYPE NAME MISSING") D LOOP1
"RTN","PSDPLOG1",70,0)
 Q
"RTN","PSDPLOG1",71,0)
LOOP1 ;S:ASK="D" ^TMP("PSDLOG",$J,PSDNA,TYPN,PSDRN,NUM,PSDCNT)=QTY_"^"_PSDDT_"^"_EXPD_"^"_PSDOK
"RTN","PSDPLOG1",72,0)
 S:'$G(TYP) TYP=999999
"RTN","PSDPLOG1",73,0)
 D:ASK="D"
"RTN","PSDPLOG1",74,0)
 .S ^TMP("PSDLOG",$J,"B",PSDNA,PSD)="",^TMP("PSDLOG",$J,PSD,+TYP)=0
"RTN","PSDPLOG1",75,0)
 .S ^TMP("PSDLOG",$J,PSD,"B",TYPN,+TYP)=""
"RTN","PSDPLOG1",76,0)
 .S ^TMP("PSDLOG",$J,PSD,+TYP,PSDR,NUM,PSDCNT)=QTY_U_PSDDT_U_EXPD_U_PSDOK
"RTN","PSDPLOG1",77,0)
 .S ^TMP("PSDLOG",$J,PSD,+TYP,"B",PSDRN,PSDR)=""
"RTN","PSDPLOG1",78,0)
 ;S:ASK="N" ^TMP("PSDLOG",$J,PSDNA,TYPN,NUM,PSDRN,PSDCNT)=QTY_"^"_PSDDT_"^"_EXPD_"^"_PSDOK
"RTN","PSDPLOG1",79,0)
 D:ASK="N"
"RTN","PSDPLOG1",80,0)
 .S ^TMP("PSDLOG",$J,"B",PSDNA,PSD)="",^TMP("PSDLOG",$J,PSD,+TYP)=0
"RTN","PSDPLOG1",81,0)
 .S ^TMP("PSDLOG",$J,PSD,"B",TYPN,+TYP)=""
"RTN","PSDPLOG1",82,0)
 .S ^TMP("PSDLOG",$J,PSD,+TYP,NUM,PSDR,PSDCNT)=QTY_U_PSDDT_U_EXPD_U_PSDOK_U_PSDRN
"RTN","PSDPLOG1",83,0)
 Q
"RTN","PSDPLOG2")
0^7^B17681782^B16699847
"RTN","PSDPLOG2",1,0)
PSDPLOG2 ;BIR/JPW  -Inspector's Log (cont'd) ;2 Aug 94
"RTN","PSDPLOG2",2,0)
 ;;3.0;CONTROLLED SUBSTANCES;**73**;13 Feb 97;Build 8
"RTN","PSDPLOG2",3,0)
PRINT ;print inspector's log by naou, drug and green sheet #
"RTN","PSDPLOG2",4,0)
 S (PG,PSDOUT,NAOU)=0 D NOW^%DTC S Y=+$E(%,1,12) X ^DD("DD") S RPDT=Y
"RTN","PSDPLOG2",5,0)
 K LN S $P(LN,"-",132)="" I '$D(^TMP("PSDLOG",$J)) D HDR W !!,?45,"****  NO PENDING NARCOTIC ORDERS FOR INSPECTION  ****",! G DONE
"RTN","PSDPLOG2",6,0)
 S NAOU="" F  S NAOU=$O(^TMP("PSDLOG",$J,NAOU)) Q:NAOU=""!(PSDOUT)  D HDR Q:PSDOUT  W !,?2,"=> NAOU: ",NAOU,! S LNUM=$Y D  Q:PSDOUT  D PRT
"RTN","PSDPLOG2",7,0)
 .I ASKN D LOOP2 Q
"RTN","PSDPLOG2",8,0)
 .S PSDRN="" F  S PSDRN=$O(^TMP("PSDLOG",$J,NAOU,PSDRN)) Q:PSDRN=""!(PSDOUT)  D  Q:PSDOUT
"RTN","PSDPLOG2",9,0)
 ..I $Y+8>IOSL D PRT,HDR Q:PSDOUT  W !,?2,"=> NAOU: ",NAOU,! S LNUM=$Y
"RTN","PSDPLOG2",10,0)
 ..S NUM="" F  S NUM=$O(^TMP("PSDLOG",$J,NAOU,PSDRN,NUM)) Q:NUM=""!(PSDOUT)  F PSDCNT=0:0 S PSDCNT=$O(^TMP("PSDLOG",$J,NAOU,PSDRN,NUM,PSDCNT)) Q:'PSDCNT!(PSDOUT)  D  Q:PSDOUT
"RTN","PSDPLOG2",11,0)
 ...I $Y+8>IOSL D PRT,HDR Q:PSDOUT  W !,?2,"=> NAOU: ",NAOU,! S LNUM=$Y
"RTN","PSDPLOG2",12,0)
 ...S NODE=$G(^TMP("PSDLOG",$J,NAOU,PSDRN,NUM,PSDCNT))
"RTN","PSDPLOG2",13,0)
 ...W !,$P(NODE,"^",4),?2,$S(ASK="N":PSDRN,1:NUM),?13,$S(ASK="D":PSDRN,1:NUM),$$SCH($P(NODE,"^",6)),?65,$P(NODE,"^",2),?72,$J($P(NODE,"^"),6),?91,$P(NODE,"^",3),?104,"____________",?118,"____________",!
"RTN","PSDPLOG2",14,0)
 ...S LNUM=$Y
"RTN","PSDPLOG2",15,0)
DONE I $E(IOST)'="C" W @IOF
"RTN","PSDPLOG2",16,0)
 I $E(IOST,1,2)="C-",'PSDOUT W ! K DIR,DIRUT S DIR(0)="EA",DIR("A")="END OF REPORT!  Press <RET> to return to the menu" D ^DIR K DIR
"RTN","PSDPLOG2",17,0)
END K %,%DT,%H,%I,%ZIS,ALL,ANS,ASK,ASKN,CNT,COMM,DA,DIC,DIE,DIR,DIROUT,DIRUT,DIWF,DIWL,DIWR,DR,DTOUT,DUOUT,EXP,EXPD,JJ,LN,LNUM,LOOP,LOT,MFG,NAOU,NODE,NODE3,NUM
"RTN","PSDPLOG2",18,0)
 K OK,ORD,ORDN,PG,PSD,PSDA,PSDCNT,PSDDT,PSDG,PSDIO,PSDOK,PSDN,PSDNA,PSDOUT,PSDR,PSDRN,PSDSD,PSDST,PSDT,PSDTR,QTY,REQD,REQDT,RPDT,RQTY
"RTN","PSDPLOG2",19,0)
 K SEL,STAT,STATN,TEXT,TYP,TYPN,X,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
"RTN","PSDPLOG2",20,0)
 K ^TMP("PSDLOG",$J) D ^%ZISC
"RTN","PSDPLOG2",21,0)
 S:$D(ZTQUEUED) ZTREQ="@"
"RTN","PSDPLOG2",22,0)
 Q
"RTN","PSDPLOG2",23,0)
HDR ;header for log
"RTN","PSDPLOG2",24,0)
 I $E(IOST,1,2)="C-",PG W ! K DA,DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSDOUT=1 Q
"RTN","PSDPLOG2",25,0)
 S PG=PG+1 W:$Y @IOF W !,?42,"Inspector's Log for Controlled Substances",?120,"Page: ",PG,!,?52,RPDT,!
"RTN","PSDPLOG2",26,0)
 W !,?67,"DATE",?80,"QTY"
"RTN","PSDPLOG2",27,0)
 W !,"DISP #",?13,"DRUG",?65,"DISPENSED",?78,"DISPENSED",?91,"EXP DATE",?104,"QTY ON HAND",?118,"NAME/DATE"
"RTN","PSDPLOG2",28,0)
 W !,LN,!
"RTN","PSDPLOG2",29,0)
 Q
"RTN","PSDPLOG2",30,0)
LOOP2 ;print inv typ loop
"RTN","PSDPLOG2",31,0)
 S TYPN="" F  S TYPN=$O(^TMP("PSDLOG",$J,NAOU,TYPN)) Q:TYPN=""!(PSDOUT)  W !,?4,"=> INVENTORY TYPE: ",$S($E(TYPN,1,2)="ZZ":$E(TYPN,3,99),1:TYPN),! S LNUM=$Y D
"RTN","PSDPLOG2",32,0)
 .S PSDRN="" F  S PSDRN=$O(^TMP("PSDLOG",$J,NAOU,TYPN,PSDRN)) Q:PSDRN=""!(PSDOUT)  D  Q:PSDOUT
"RTN","PSDPLOG2",33,0)
 ..I $Y+8>IOSL D PRT,HDR Q:PSDOUT  W !,?2,"=> NAOU: ",NAOU,! W:ASKN !,?4,"=> INVENTORY TYPE: ",$S($E(TYPN,1,2)="ZZ":$E(TYPN,3,99),1:TYPN),! S LNUM=$Y
"RTN","PSDPLOG2",34,0)
 ..S NUM="" F  S NUM=$O(^TMP("PSDLOG",$J,NAOU,TYPN,PSDRN,NUM)) Q:NUM=""!(PSDOUT)  F PSDCNT=0:0 S PSDCNT=$O(^TMP("PSDLOG",$J,NAOU,TYPN,PSDRN,NUM,PSDCNT)) Q:'PSDCNT!(PSDOUT)  D  Q:PSDOUT
"RTN","PSDPLOG2",35,0)
 ...I $Y+8>IOSL D PRT,HDR Q:PSDOUT  W !,?2,"=> NAOU: ",NAOU,! W:ASKN !,?4,"=> INVENTORY TYPE: ",TYPN,! S LNUM=$Y
"RTN","PSDPLOG2",36,0)
 ...S NODE=$G(^TMP("PSDLOG",$J,NAOU,TYPN,PSDRN,NUM,PSDCNT))
"RTN","PSDPLOG2",37,0)
 ...W !,$P(NODE,"^",4),?2,$S(ASK="N":PSDRN,1:NUM),?13,$S(ASK="D":PSDRN,1:NUM),$$SCH($P(NODE,"^",6)),?65,$P(NODE,"^",2),?72,$J($P(NODE,"^"),6),?91,$P(NODE,"^",3),?104,"____________",?118,"____________",!
"RTN","PSDPLOG2",38,0)
 ...S LNUM=$Y
"RTN","PSDPLOG2",39,0)
 Q
"RTN","PSDPLOG2",40,0)
PRT ;
"RTN","PSDPLOG2",41,0)
 I LNUM<IOSL-7 F JJ=LNUM:1:IOSL-7 W !
"RTN","PSDPLOG2",42,0)
 W LN,!,"*  - Transferred to another NAOU but not yet received",!,"** - Filled not yet received",!,"#  - Returned to Stock",!
"RTN","PSDPLOG2",43,0)
 Q
"RTN","PSDPLOG2",44,0)
SCH(X) ;schedule conversion
"RTN","PSDPLOG2",45,0)
 N DEA
"RTN","PSDPLOG2",46,0)
 S DEA=+$P($G(^PSDRUG(X,0)),"^",3)
"RTN","PSDPLOG2",47,0)
 Q:+DEA<1 ""
"RTN","PSDPLOG2",48,0)
 Q " (Schedule "_$P("I^II^III^IV^V","^",DEA)_")"
"RTN","PSDPLOG3")
0^8^B20151384^B19498393
"RTN","PSDPLOG3",1,0)
PSDPLOG3 ;BIR/JPW,LTL - Inspector's Log (cont'd) ;31 May 95
"RTN","PSDPLOG3",2,0)
 ;;3.0;CONTROLLED SUBSTANCES;**73**;13 Feb 97;Build 8
"RTN","PSDPLOG3",3,0)
PRINT ;print inspector's log by naou, drug and green sheet #
"RTN","PSDPLOG3",4,0)
 S (PG,PSDOUT,NAOU)=0 D NOW^%DTC S Y=+$E(%,1,12) X ^DD("DD") S RPDT=Y
"RTN","PSDPLOG3",5,0)
 K LN S $P(LN,"-",132)="" I '$D(^TMP("PSDLOG",$J)) D HDR W !!,?45,"****  NO PENDING NARCOTIC ORDERS FOR INSPECTION  ****",! G DONE
"RTN","PSDPLOG3",6,0)
 S NAOU="" F  S NAOU=$O(^TMP("PSDLOG",$J,"B",NAOU)) Q:NAOU=""!(PSDOUT)  D HDR Q:PSDOUT  W !,?2,"=> NAOU: ",NAOU,! S LNUM=$Y D LOOP2 Q:PSDOUT  D PRT
"RTN","PSDPLOG3",7,0)
 D:'PSDOUT PRT
"RTN","PSDPLOG3",8,0)
DONE I $E(IOST)'="C" W @IOF
"RTN","PSDPLOG3",9,0)
 I $E(IOST,1,2)="C-",'PSDOUT W ! K DIR,DIRUT S DIR(0)="EA",DIR("A")="END OF REPORT!  Press <RET> to return to the menu" D ^DIR K DIR
"RTN","PSDPLOG3",10,0)
END K %,%DT,%H,%I,%ZIS,ALL,ANS,ASK,ASKN,CNT,COMM,DA,DIC,DIE,DIR,DIROUT,DIRUT,DIWF,DIWL,DIWR,DR,DTOUT,DUOUT,EXP,EXPD,JJ,LN,LNUM,LOOP,LOT,MFG,NAOU,NODE,NODE3,NUM
"RTN","PSDPLOG3",11,0)
 K OK,ORD,ORDN,PG,PSD,PSDA,PSDCNT,PSDDT,PSDG,PSDIO,PSDOK,PSDN,PSDNA,PSDOUT,PSDR,PSDRN,PSDSD,PSDST,PSDT,PSDTR,QTY,REQD,REQDT,RPDT,RQTY
"RTN","PSDPLOG3",12,0)
 K SEL,STAT,STATN,TEXT,TYP,TYPN,X,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
"RTN","PSDPLOG3",13,0)
 K ^TMP("PSDLOG",$J) D ^%ZISC
"RTN","PSDPLOG3",14,0)
 S:$D(ZTQUEUED) ZTREQ="@"
"RTN","PSDPLOG3",15,0)
 Q
"RTN","PSDPLOG3",16,0)
HDR ;header for log
"RTN","PSDPLOG3",17,0)
 I $E(IOST,1,2)="C-",PG W ! K DA,DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSDOUT=1 Q
"RTN","PSDPLOG3",18,0)
 S PG=PG+1 W:$Y @IOF W !,?42,"Inspector's Log for Controlled Substances",?120,"Page: ",PG,!,?52,RPDT,!
"RTN","PSDPLOG3",19,0)
 W !,?67,"DATE",?80,"QTY"
"RTN","PSDPLOG3",20,0)
 W !,"DISP #",?13,"DRUG",?65,"DISPENSED",?78,"DISPENSED",?91,"EXP DATE",?104,"QTY ON HAND",?118,"NAME/DATE"
"RTN","PSDPLOG3",21,0)
 W !,LN,!
"RTN","PSDPLOG3",22,0)
 Q
"RTN","PSDPLOG3",23,0)
LOOP2 ;print inv typ loop
"RTN","PSDPLOG3",24,0)
 S NAOU(1)=$O(^TMP("PSDLOG",$J,"B",NAOU,0))
"RTN","PSDPLOG3",25,0)
 S TYPN="" F  S TYPN=$O(^TMP("PSDLOG",$J,NAOU(1),"B",TYPN)) Q:TYPN=""!(PSDOUT)  W !,?4,"=> INVENTORY TYPE: ",$S($E(TYPN,1,2)="ZZ":$E(TYPN,3,99),1:TYPN),! S LNUM=$Y D
"RTN","PSDPLOG3",26,0)
 .S TYPN(1)=$O(^TMP("PSDLOG",$J,NAOU(1),"B",TYPN,0))
"RTN","PSDPLOG3",27,0)
 .I ASK="N" D  Q
"RTN","PSDPLOG3",28,0)
 ..S NUM=0
"RTN","PSDPLOG3",29,0)
 ..F  S NUM=$O(^TMP("PSDLOG",$J,NAOU(1),TYPN(1),NUM)) Q:NUM=""!(PSDOUT)  D  Q:PSDOUT
"RTN","PSDPLOG3",30,0)
 ...I $Y+8>IOSL D PRT,HDR Q:PSDOUT  W !,?2,"=> NAOU: ",NAOU,!!?4,"=> INVENTORY TYPE: ",$S($E(TYPN,1,2)="ZZ":$E(TYPN,3,99),1:TYPN),! S LNUM=$Y
"RTN","PSDPLOG3",31,0)
 ...S PSDR=0
"RTN","PSDPLOG3",32,0)
 ...F  S PSDR=$O(^TMP("PSDLOG",$J,NAOU(1),TYPN(1),NUM,PSDR)) Q:'PSDR!(PSDOUT)  S PSDCNT=0 F  S PSDCNT=$O(^TMP("PSDLOG",$J,NAOU(1),TYPN(1),NUM,PSDR,PSDCNT)) Q:'PSDCNT!(PSDOUT)  D  Q:PSDOUT
"RTN","PSDPLOG3",33,0)
 ....I $Y+8>IOSL D PRT,HDR Q:PSDOUT  W !,?2,"=> NAOU: ",NAOU,!!?4,"=> INVENTORY TYPE: ",$S($E(TYPN,1,2)="ZZ":$E(TYPN,3,99),1:TYPN),! S LNUM=$Y
"RTN","PSDPLOG3",34,0)
 ....S NODE=$G(^TMP("PSDLOG",$J,NAOU(1),TYPN(1),NUM,PSDR,PSDCNT))
"RTN","PSDPLOG3",35,0)
 ....W !,$P(NODE,U,4),?2,NUM,?13,$P(NODE,U,5)_$$SCH^PSDPLOG2(PSDR),?65,$P(NODE,U,2),?72,$J($P(NODE,U),6),?91,$P(NODE,U,3),?104,"____________",?118,"____________",! S LNUM=$Y
"RTN","PSDPLOG3",36,0)
 .S PSDRN="" F  S PSDRN=$O(^TMP("PSDLOG",$J,NAOU(1),TYPN(1),"B",PSDRN)) Q:PSDRN=""!(PSDOUT)  D  Q:PSDOUT
"RTN","PSDPLOG3",37,0)
 ..I $Y+8>IOSL D PRT,HDR Q:PSDOUT  W !,?2,"=> NAOU: ",NAOU,! W:ASKN !,?4,"=> INVENTORY TYPE: ",$S($E(TYPN,1,2)="ZZ":$E(TYPN,3,99),1:TYPN),! S LNUM=$Y
"RTN","PSDPLOG3",38,0)
 ..S PSDRN(1)=$O(^TMP("PSDLOG",$J,NAOU(1),TYPN(1),"B",PSDRN,0))
"RTN","PSDPLOG3",39,0)
 ..S NUM="" F  S NUM=$O(^TMP("PSDLOG",$J,NAOU(1),TYPN(1),PSDRN(1),NUM)) Q:NUM=""!(PSDOUT)  F PSDCNT=0:0 S PSDCNT=$O(^TMP("PSDLOG",$J,NAOU(1),TYPN(1),PSDRN(1),NUM,PSDCNT)) Q:'PSDCNT!(PSDOUT)  D  Q:PSDOUT
"RTN","PSDPLOG3",40,0)
 ...I $Y+8>IOSL D PRT,HDR Q:PSDOUT  W !,?2,"=> NAOU: ",NAOU,! W:ASKN !,?4,"=> INVENTORY TYPE: ",TYPN,! S LNUM=$Y
"RTN","PSDPLOG3",41,0)
 ...S NODE=$G(^TMP("PSDLOG",$J,NAOU(1),TYPN(1),PSDRN(1),NUM,PSDCNT))
"RTN","PSDPLOG3",42,0)
 ...W !,$P(NODE,"^",4),?2,$S(ASK="N":PSDRN,1:NUM),?13,$S(ASK="D":PSDRN,1:NUM),$$SCH^PSDPLOG2(PSDRN(1)),?65,$P(NODE,"^",2),?72,$J($P(NODE,"^"),6),?91,$P(NODE,"^",3),?104,"____________",?118,"____________",!
"RTN","PSDPLOG3",43,0)
 ...S LNUM=$Y
"RTN","PSDPLOG3",44,0)
 Q
"RTN","PSDPLOG3",45,0)
PRT ;
"RTN","PSDPLOG3",46,0)
 I LNUM<IOSL-7 F JJ=LNUM:1:IOSL-7 W !
"RTN","PSDPLOG3",47,0)
 W LN,!,"*  - Transferred to another NAOU but not yet received",!,"** - Filled not yet received",!,"#  - Returned to Stock",!
"RTN","PSDPLOG3",48,0)
 Q
"RTN","PSDSUBOX")
0^9^B32552011^n/a
"RTN","PSDSUBOX",1,0)
PSDSUBOX ;BHAM ISC/JAM - DEA DATA - Waived Practitioner Report ;05 July 2011 5:30 pm
"RTN","PSDSUBOX",2,0)
 ;;3.0;CONTROLLED SUBSTANCES;**73**;13 Feb 97;Build 8
"RTN","PSDSUBOX",3,0)
 ;External reference to ^PS(59 supported by DBIA #2621
"RTN","PSDSUBOX",4,0)
 ;External reference to ^PSRX( supported by DBIA #1977
"RTN","PSDSUBOX",5,0)
 ;External reference to ^PSDRUG( supported by DBIA #221
"RTN","PSDSUBOX",6,0)
 ;
"RTN","PSDSUBOX",7,0)
 ;ask division/site
"RTN","PSDSUBOX",8,0)
 N PSDIV,PSPRV,RPTYP,PSDED,PSDBD,PSDSD
"RTN","PSDSUBOX",9,0)
 D DIVSEL(.PSDIV) I $G(PSDIV)="^" G EXIT
"RTN","PSDSUBOX",10,0)
 I $G(PSDIV)="^ALL" S PSDIV=0 F  S PSDIV=$O(^PS(59,PSDIV)) Q:'PSDIV  I $S('$D(^PS(59,+PSDIV,"I")):1,'^("I"):1,DT'>^("I"):1,1:0) S PSDIV(PSDIV)=""
"RTN","PSDSUBOX",11,0)
 I '$D(PSDIV) G EXIT
"RTN","PSDSUBOX",12,0)
 ;
"RTN","PSDSUBOX",13,0)
DATE ;ask date range
"RTN","PSDSUBOX",14,0)
 W ! K %DT S %DT(0)=-DT,%DT="AEP",%DT("A")="Start Date: " D ^%DT
"RTN","PSDSUBOX",15,0)
 I Y<0!($D(DTOUT)) G EXIT
"RTN","PSDSUBOX",16,0)
 S (%DT(0),PSDBD)=Y,%DT("A")="End Date: "
"RTN","PSDSUBOX",17,0)
 W ! D ^%DT I Y<0!($D(DTOUT)) G EXIT
"RTN","PSDSUBOX",18,0)
 S PSDED=Y,PSDSD=PSDBD-.000001
"RTN","PSDSUBOX",19,0)
PRV ;ask provider(s)
"RTN","PSDSUBOX",20,0)
 W !!,?5,"You may select a single provider, several providers,",!,?5,"or enter ^ALL to select all providers.",!!
"RTN","PSDSUBOX",21,0)
 K PRV,DIC S DIC("A")="Select Provider: ",DIC=200,DIC(0)="QEAM"
"RTN","PSDSUBOX",22,0)
 S DIC("S")="I $D(^(""PS"")),$P(^(""PS""),""^""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)'<DT)"
"RTN","PSDSUBOX",23,0)
 F  D ^DIC Q:+Y<0  S PSPRV(+Y)=""
"RTN","PSDSUBOX",24,0)
 K DIC I $$UP^XLFSTR(X)="^ALL" K DUOUT G TYP
"RTN","PSDSUBOX",25,0)
 I ($D(DUOUT))!($D(DTOUT)) G EXIT
"RTN","PSDSUBOX",26,0)
 I '$D(PSPRV)&(Y<0) G PRV
"RTN","PSDSUBOX",27,0)
TYP  ;ask report selection - detail or summary
"RTN","PSDSUBOX",28,0)
 S DIR(0)="SA^D:Detailed;S:Summary",DIR("A")="Detailed/Summary Report: ",DIR("B")="D"
"RTN","PSDSUBOX",29,0)
 D ^DIR
"RTN","PSDSUBOX",30,0)
 I $D(DIRUT) G EXIT
"RTN","PSDSUBOX",31,0)
 S RPTYP=Y
"RTN","PSDSUBOX",32,0)
 W ! K %ZIS,IOP,IO("Q"),POP S %ZIS="QM",%ZIS("B")="" D ^%ZIS I POP W !!,"NO DEVICE SELECTED OR REPORT PRINTED!!",! K IOP G EXIT
"RTN","PSDSUBOX",33,0)
 I $D(IO("Q")) D  G EXIT
"RTN","PSDSUBOX",34,0)
 .S ZTRTN="RPT^PSDSUBOX",ZTDESC="DEA Waived Practitioner Report",ZTSAVE("PSDIV(")="",ZTSAVE("PSPRV(")=""
"RTN","PSDSUBOX",35,0)
 .F G="PSDSD","PSDED","PSDBD","RPTYP" S:$D(@G) ZTSAVE(G)=""
"RTN","PSDSUBOX",36,0)
 .D ^%ZTLOAD W:$D(ZTSK) !,"Report Queued to Print !!",! D HOME^%ZIS K ZTSK,IO("Q")
"RTN","PSDSUBOX",37,0)
 U IO
"RTN","PSDSUBOX",38,0)
 ;
"RTN","PSDSUBOX",39,0)
RPT ;generate report
"RTN","PSDSUBOX",40,0)
 N RXN,ND0,ND2,DRGDA,DRGNM,DEA,DIV,PRVDA,PRVNM,PG,DTM
"RTN","PSDSUBOX",41,0)
 S PG=1,DTM=$$FMTE^XLFDT(DT)
"RTN","PSDSUBOX",42,0)
 K ^TMP("PSDSUBOX",$J)
"RTN","PSDSUBOX",43,0)
 F  S PSDSD=$O(^PSRX("AFDT",PSDSD)) Q:'PSDSD!(PSDSD>(PSDED+.99))  D
"RTN","PSDSUBOX",44,0)
 .S RXN=0 F  S RXN=$O(^PSRX("AFDT",PSDSD,RXN)) Q:'RXN  D
"RTN","PSDSUBOX",45,0)
 ..S ND0=$G(^PSRX(RXN,0)),DRGDA=$P(ND0,"^",6),DRGNM=$$GET1^DIQ(50,DRGDA,.01),DEA=$$GET1^DIQ(50,DRGDA,3)
"RTN","PSDSUBOX",46,0)
 ..Q:DEA<1  Q:DEA>5  Q:'$$DETOX^PSSOPKI(DRGDA)
"RTN","PSDSUBOX",47,0)
 ..S ND2=$G(^PSRX(RXN,2)),DIV=$P(ND2,"^",9),PRVDA=$P(ND0,"^",4),PRVNM=$$GET1^DIQ(59,PRVDA,.01)
"RTN","PSDSUBOX",48,0)
 ..I '$D(PSDIV(+DIV)) Q
"RTN","PSDSUBOX",49,0)
 ..I $D(PSPRV) I '$D(PSPRV(+PRVDA)) Q
"RTN","PSDSUBOX",50,0)
 ..D SETMP
"RTN","PSDSUBOX",51,0)
 D PRT
"RTN","PSDSUBOX",52,0)
 ;
"RTN","PSDSUBOX",53,0)
EXIT D ^%ZISC K PG,G,DR,X,Y,DIR,DIRUT,DUOUT,I,Y,DIC,DTOUT,%DT
"RTN","PSDSUBOX",54,0)
 K ZTDESC,ZTRTN,ZTSAVE S:$D(ZTQUEUED) ZTREQ="@" K ZTQUEUED D KVA^VADPT
"RTN","PSDSUBOX",55,0)
 Q
"RTN","PSDSUBOX",56,0)
 ;
"RTN","PSDSUBOX",57,0)
SETMP ;set ^TMP("PSDSUBOX",$J global
"RTN","PSDSUBOX",58,0)
 S ^TMP("PSDSUBOX",$J,DIV,$E(DRGNM,1,30)_"^"_DRGDA,$E(PRVNM,1,30)_"^"_PRVDA)=$G(^TMP("PSDSUBOX",$J,DIV,$E(DRGNM,1,30)_"^"_DRGDA,$E(PRVNM,1,30)_"^"_PRVDA))+1
"RTN","PSDSUBOX",59,0)
 S ^TMP("PSDSUBOX",$J,DIV,$E(DRGNM,1,30)_"^"_DRGDA,$E(PRVNM,1,30)_"^"_PRVDA,RXN)=""
"RTN","PSDSUBOX",60,0)
 Q
"RTN","PSDSUBOX",61,0)
 ;
"RTN","PSDSUBOX",62,0)
PRT ;prints report
"RTN","PSDSUBOX",63,0)
 N DIV,DRG,PRV,PSDATE,PEDATE,PSDOUT
"RTN","PSDSUBOX",64,0)
 S PSDOUT=0,PSDATE=$$FMTE^XLFDT(PSDBD),PEDATE=$$FMTE^XLFDT(PSDED)
"RTN","PSDSUBOX",65,0)
 I '$D(^TMP("PSDSUBOX",$J)) D HD W !,?25,"***NO DATA FOUND FOR SELECTION***",!! D HD1^PSDDSOR I $D(DIRUT) Q
"RTN","PSDSUBOX",66,0)
 S DIV=0 F  S DIV=$O(^TMP("PSDSUBOX",$J,DIV)) Q:'DIV  D  I PSDOUT Q
"RTN","PSDSUBOX",67,0)
 .D HD,PGCHK I PSDOUT Q
"RTN","PSDSUBOX",68,0)
 .S DRG="" F  S DRG=$O(^TMP("PSDSUBOX",$J,DIV,DRG)) Q:DRG=""  D  I PSDOUT Q
"RTN","PSDSUBOX",69,0)
 ..W ! I RPTYP="S" W $P(DRG,"^")
"RTN","PSDSUBOX",70,0)
 ..S PRV="" F  S PRV=$O(^TMP("PSDSUBOX",$J,DIV,DRG,PRV)) Q:PRV=""  D  I PSDOUT Q
"RTN","PSDSUBOX",71,0)
 ...D PRT1 Q:PSDOUT  D PGCHK
"RTN","PSDSUBOX",72,0)
 ..I RPTYP="S" W !
"RTN","PSDSUBOX",73,0)
 Q
"RTN","PSDSUBOX",74,0)
 ;
"RTN","PSDSUBOX",75,0)
PRT1 ;print report details
"RTN","PSDSUBOX",76,0)
 N ND0,LIN,DFN,PL,EE
"RTN","PSDSUBOX",77,0)
 I RPTYP="S" W !?3,$$GET1^DIQ(200,$P(PRV,"^",2),.01),?45,$J(^TMP("PSDSUBOX",$J,DIV,DRG,PRV),6) Q
"RTN","PSDSUBOX",78,0)
 S RXN=0 F  S RXN=$O(^TMP("PSDSUBOX",$J,DIV,DRG,PRV,RXN)) Q:'RXN  D  Q:PSDOUT
"RTN","PSDSUBOX",79,0)
 .S ND0=$G(^PSRX(RXN,0)),DFN=$P(ND0,"^",2)
"RTN","PSDSUBOX",80,0)
 .W ?2,"Issue Date: ",$$FMTE^XLFDT($P(ND0,"^",13))
"RTN","PSDSUBOX",81,0)
 .D DEM^VADPT,ADD^VADPT
"RTN","PSDSUBOX",82,0)
 .W !?2,"Patient: ",VADM(1)
"RTN","PSDSUBOX",83,0)
 .W !?2,VAPA(1),$S(VAPA(2)'="":", "_VAPA(2),1:"")
"RTN","PSDSUBOX",84,0)
 .I VAPA(3)'="" W !?2,VAPA(3)
"RTN","PSDSUBOX",85,0)
 .W !?2,$S(VAPA(4)'="":VAPA(4)_", ",1:""),$P(VAPA(5),"^",2)," ",VAPA(6)
"RTN","PSDSUBOX",86,0)
 .D PGCHK I PSDOUT Q
"RTN","PSDSUBOX",87,0)
 .W !!?2,$$GET1^DIQ(50,$P(DRG,"^",2),.01),?50,"Qty: ",$P(ND0,"^",7),?60,"# of Refills: ",$P(ND0,"^",9)
"RTN","PSDSUBOX",88,0)
 .D FSIG^PSDDSOR1("R",RXN,75)
"RTN","PSDSUBOX",89,0)
 .I $G(FSIG(1))'="" D
"RTN","PSDSUBOX",90,0)
 ..W !?2,"SIG: ",$$UNESC^ORHLESC($G(FSIG(1)))
"RTN","PSDSUBOX",91,0)
 ..I $O(FSIG(1)) D
"RTN","PSDSUBOX",92,0)
 ...F EE=1:0 S EE=$O(FSIG(EE)) Q:'EE  D
"RTN","PSDSUBOX",93,0)
 ....W !?6,$$UNESC^ORHLESC($G(FSIG(EE)))
"RTN","PSDSUBOX",94,0)
 .D PGCHK I PSDOUT Q
"RTN","PSDSUBOX",95,0)
 .W !!?2,"Provider: ",$$GET1^DIQ(200,$P(ND0,"^",4),.01),!
"RTN","PSDSUBOX",96,0)
 .D VADR($$GET1^DIQ(52,RXN,39.3,"I"),.VADR)
"RTN","PSDSUBOX",97,0)
 .I $D(VADR(1)) W ?2,$P(VADR(1),"^"),!?2,VADR(2),!?2,VADR(3),!
"RTN","PSDSUBOX",98,0)
 .F LIN=1:1:80 W "="
"RTN","PSDSUBOX",99,0)
 .D PGCHK I PSDOUT Q
"RTN","PSDSUBOX",100,0)
 Q
"RTN","PSDSUBOX",101,0)
HD ;header
"RTN","PSDSUBOX",102,0)
 N DVL,DVN,LIN
"RTN","PSDSUBOX",103,0)
 W @IOF,?22,"DEA DATA-Waived Practitioner Report",?67,DTM,!,?32,$S(RPTYP="D":"Detailed",1:"Summary")_" Report"
"RTN","PSDSUBOX",104,0)
 S DVN=$P($G(^PS(59,+$G(DIV),0)),"^",1),DVL=80-(9+$L(DVN))/2
"RTN","PSDSUBOX",105,0)
 I DVN'="" W !?DVL,"DIVISION: ",DVN
"RTN","PSDSUBOX",106,0)
 W !?26,PSDATE_" to "_PEDATE,?70,"Page: "_PG,!
"RTN","PSDSUBOX",107,0)
 I RPTYP="S" W !,"DRUG/PROVIDER",?45,"# OF PATIENTS",!
"RTN","PSDSUBOX",108,0)
 F LIN=1:1:80 W "-"
"RTN","PSDSUBOX",109,0)
 S PG=PG+1
"RTN","PSDSUBOX",110,0)
 Q
"RTN","PSDSUBOX",111,0)
PGCHK ;check for page break
"RTN","PSDSUBOX",112,0)
 I ($Y+4)>IOSL D  Q
"RTN","PSDSUBOX",113,0)
 .W ! D HD1^PSDDSOR I $D(DIRUT) S PSDOUT=1 Q
"RTN","PSDSUBOX",114,0)
 .D HD W !
"RTN","PSDSUBOX",115,0)
 Q
"RTN","PSDSUBOX",116,0)
 ;
"RTN","PSDSUBOX",117,0)
DIVSEL(ARY) ;Division selection (one, multiple or ALL)
"RTN","PSDSUBOX",118,0)
 N DIC,DTOUT,DUOUT,QF,Y,X
"RTN","PSDSUBOX",119,0)
 W !!,?5,"You may select a single or multiple Divisions,"
"RTN","PSDSUBOX",120,0)
 W !,?5,"or enter ^ALL to select all Divisions.",!
"RTN","PSDSUBOX",121,0)
 S DIC("S")="I $S('$D(^PS(59,+Y,""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0)"
"RTN","PSDSUBOX",122,0)
 S DIC="^PS(59,",DIC(0)="QEZAM",DIC("A")="Division: ",QF=0
"RTN","PSDSUBOX",123,0)
 F  D ^DIC Q:X=""  D  Q:QF
"RTN","PSDSUBOX",124,0)
 .I $$UP^XLFSTR(X)="^ALL" K ARY S ARY="^ALL",QF=1 Q
"RTN","PSDSUBOX",125,0)
 .I $D(DTOUT)!$D(DUOUT) K ARY S ARY="^",QF=1 Q
"RTN","PSDSUBOX",126,0)
 .W "   ",$P(Y,"^",2),$S($D(ARY(+Y)):"       (already selected)",1:"")
"RTN","PSDSUBOX",127,0)
 .W ! S ARY(+Y)=""
"RTN","PSDSUBOX",128,0)
 I '$D(ARY) S ARY="^"
"RTN","PSDSUBOX",129,0)
 Q
"RTN","PSDSUBOX",130,0)
VADR(ORN,VADD) ;Get Provider's Address
"RTN","PSDSUBOX",131,0)
 ;ORN: Order IEN (Pointer to file #100)
"RTN","PSDSUBOX",132,0)
 K ^TMP($J,"ORDEA"),VADD
"RTN","PSDSUBOX",133,0)
 D ARCHIVE^ORDEA(ORN)
"RTN","PSDSUBOX",134,0)
 I $D(^TMP($J,"ORDEA",ORN,3)) S VADD=^(3) D
"RTN","PSDSUBOX",135,0)
 .I $P(VADD,"^",2)="" Q
"RTN","PSDSUBOX",136,0)
 .S VADD(1)=$P(VADD,"^",2),VADD(2)=$P(VADD,"^",3)
"RTN","PSDSUBOX",137,0)
 .S VADD(3)=$P(VADD,"^",4)_", "_$P(VADD,"^",5)_" "_$P(VADD,"^",6)
"RTN","PSDSUBOX",138,0)
 K ^TMP($J,"ORDEA")
"RTN","PSDSUBOX",139,0)
 Q
"VER")
8.0^22.0
**INSTALL NAME**
PSO*7.0*391
"BLD",8061,0)
PSO*7.0*391^OUTPATIENT PHARMACY^0^3130329^y
"BLD",8061,1,0)
^^284^284^3130329^
"BLD",8061,1,1,0)
This patch is being released as part of the DEA e-Prescribing of
"BLD",8061,1,2,0)
Controlled Substances (CS) project using Public Key Infrastructure (PKI)
"BLD",8061,1,3,0)
to satisfy requirements requested by the Drug Enforcement Administration
"BLD",8061,1,4,0)
(DEA).
"BLD",8061,1,5,0)
The applications involved in this project along with their patch numbers 
"BLD",8061,1,6,0)
are listed below and the same order should be followed when installing 
"BLD",8061,1,7,0)
the patches.
"BLD",8061,1,8,0)
 
"BLD",8061,1,9,0)
   APPLICATION                                            PATCH
"BLD",8061,1,10,0)
   -----------------------------------------------------------------
"BLD",8061,1,11,0)
   KERNEL V. 8.0                                          XU*8*580
"BLD",8061,1,12,0)
   PHARMACY DATA MANAGEMENT (PDM) V. 1.0                  PSS*1*166
"BLD",8061,1,13,0)
   COMPUTERIZED PATIENT RECORD SYSTEM (CPRS) V. 3.0       OR*3*306
"BLD",8061,1,14,0)
   CONTROLLED SUBSTANCES (CS) V. 3.0                      PSD*3*73
"BLD",8061,1,15,0)
   OUTPATIENT PHARMACY (OP) V. 7.0                        PSO*7*391
"BLD",8061,1,16,0)
 
"BLD",8061,1,17,0)
Note:
"BLD",8061,1,18,0)
1. A new security key named "PSDRPH", has been sent out in the Controlled
"BLD",8061,1,19,0)
   Substances patch PSD*3*76, which is a required patch for this patch.
"BLD",8061,1,20,0)
   This key authorizes pharmacists to finish/verify a digitally signed
"BLD",8061,1,21,0)
   Schedule II-V CS orders placed via CPRS and should be assigned to
"BLD",8061,1,22,0)
   registered pharmacists working with Schedule II-V drugs.
"BLD",8061,1,23,0)
 
"BLD",8061,1,24,0)
2. Patches PSO*7*391 and PSD*3*73 are being released in the Kernel 
"BLD",8061,1,25,0)
   Installation and Distribution System (KIDS) multi-build distribution
"BLD",8061,1,26,0)
   CPRSV29_PSO_PSD. 
"BLD",8061,1,27,0)
 
"BLD",8061,1,28,0)
The following modifications and enhancements are included in this patch 
"BLD",8061,1,29,0)
(PSO*7*391):
"BLD",8061,1,30,0)
 
"BLD",8061,1,31,0)
1. When processing a digitally signed pending order, the integrity of the 
"BLD",8061,1,32,0)
original order placed in CPRS is now being checked to ensure that the data
"BLD",8061,1,33,0)
fields listed below are not altered from the time the order is signed in
"BLD",8061,1,34,0)
CPRS and later selected for processing in backdoor pharmacy. This is done
"BLD",8061,1,35,0)
by passing the data elements listed below to a Kernel Application
"BLD",8061,1,36,0)
Programming Interface (API), Integration Control Registration (ICR) #3539,
"BLD",8061,1,37,0)
along with the CPRS hash count, provided by ICR #5709. The Kernel API
"BLD",8061,1,38,0)
compares these two hash values and returns an "OK" if the pending order is
"BLD",8061,1,39,0)
unaltered or otherwise, returns a "-1^error code^error message."
"BLD",8061,1,40,0)
 
"BLD",8061,1,41,0)
Example: "-1^89802016^Mismatched digital signature hash values."
"BLD",8061,1,42,0)
 
"BLD",8061,1,43,0)
These are the fields used in the hash check:
"BLD",8061,1,44,0)
        Date of Issuance
"BLD",8061,1,45,0)
        Full Name and Address of the Patient
"BLD",8061,1,46,0)
        Drug Name
"BLD",8061,1,47,0)
        Quantity Prescribed  
"BLD",8061,1,48,0)
        Directions for Use
"BLD",8061,1,49,0)
        Prescriber Name   
"BLD",8061,1,50,0)
        Prescriber Address (site address) 
"BLD",8061,1,51,0)
        Prescriber DEA / VA Registration Number
"BLD",8061,1,52,0)
        Order Number (CPRS)
"BLD",8061,1,53,0)
 
"BLD",8061,1,54,0)
The Kernel API will also check for the validity of the DEA certificate. If
"BLD",8061,1,55,0)
the certificate is revoked or expired then the API will return the
"BLD",8061,1,56,0)
appropriate error code.
"BLD",8061,1,57,0)
If the error code is related to hash mismatch or the DEA certificate is
"BLD",8061,1,58,0)
revoked then the following events will be triggered during pending order
"BLD",8061,1,59,0)
processing:
"BLD",8061,1,60,0)
  The order will be auto discontinued.
"BLD",8061,1,61,0)
  First line of the pending order screen will have the message "Digital
"BLD",8061,1,62,0)
  Signature Failed: Corrupted (Hash mismatch)" or "Certificate revoked"
"BLD",8061,1,63,0)
  concatenated with "Order Auto Discontinued", and the message will be
"BLD",8061,1,64,0)
  highlighted in reverse video.
"BLD",8061,1,65,0)
  The status bar of the screen will have the message "Signature Failed: 
"BLD",8061,1,66,0)
  Corrupted (Hash mismatch)" or Certificate revoked."
"BLD",8061,1,67,0)
  A mail message will be generated to the holders of the PSDMGR key 
"BLD",8061,1,68,0)
  notifying that the order has been auto discontinued (similar to the 
"BLD",8061,1,69,0)
  example listed below).
"BLD",8061,1,70,0)
  If the discontinuation is due to a hash mismatch as a result of altering
"BLD",8061,1,71,0)
  one of the fields listed above then the mail message will show the
"BLD",8061,1,72,0)
  altered fields with the discrepancies. Here is an example:
"BLD",8061,1,73,0)
 
"BLD",8061,1,74,0)
  Subj: DIGITALLY SIGNED NEW ORDER AUTO DISCONTINUED  [#196353] 
"BLD",8061,1,75,0)
        03/20/12@17:1024 lines
"BLD",8061,1,76,0)
  From: POSTMASTER  In 'IN' basket.   Page 1  *New*
"BLD",8061,1,77,0)
         
"BLD",8061,1,78,0)
  -----------------------------------------------------------------------
"BLD",8061,1,79,0)
 
"BLD",8061,1,80,0)
  Following order was auto discontinued when finishing a pending order   
"BLD",8061,1,81,0)
  due to Corrupted (Hash mismatch) - 89802016
"BLD",8061,1,82,0)
 
"BLD",8061,1,83,0)
  Division      : GREELEY CLINIC
"BLD",8061,1,84,0)
  CPRS Order #  : 5587651
"BLD",8061,1,85,0)
  Issue Date    : MAR 7,2012
"BLD",8061,1,86,0)
  Patient       : TEST,PATIENT (0908)
"BLD",8061,1,87,0)
  Address       : P.O. BOX 31
"BLD",8061,1,88,0)
                  LAPORTE, CA  95981
"BLD",8061,1,89,0)
  Drug          : CODEINE SULFATE 60MG TAB
"BLD",8061,1,90,0)
  Dosage Ordered: 120(MG)
"BLD",8061,1,91,0)
  Dosage Form   : TABLETS
"BLD",8061,1,92,0)
  Quantity      : 54
"BLD",8061,1,93,0)
  Provider      : TEST,PROVIDER
"BLD",8061,1,94,0)
  DEA#          : TA1234563
"BLD",8061,1,95,0)
  Site Address  : 2360 E PERSHING BLVD
"BLD",8061,1,96,0)
                  2360 East Pershing Boulevard
"BLD",8061,1,97,0)
                  CHEYENNE
"BLD",8061,1,98,0)
 
"BLD",8061,1,99,0)
  Differences in CPRS and Pharmacy Pending File
"BLD",8061,1,100,0)
 
"BLD",8061,1,101,0)
  Data Name           CPRS File         Pharmacy Pending File
"BLD",8061,1,102,0)
  ---------           ---------         ---------------------
"BLD",8061,1,103,0)
  QTY PRESCRIBED      15                30
"BLD",8061,1,104,0)
 
"BLD",8061,1,105,0)
         
"BLD",8061,1,106,0)
  If the error code is related to 'certificate expired', the pending 
"BLD",8061,1,107,0)
  order will be processed (will not be auto discontinued) and a 
"BLD",8061,1,108,0)
  notification will be sent to the provider with the message, "DEA
"BLD",8061,1,109,0)
  certificate expired. Renew your certificate."
"BLD",8061,1,110,0)
 
"BLD",8061,1,111,0)
2. When finishing a pending CS order, if the user does not hold the new 
"BLD",8061,1,112,0)
   PSDRPH security key, the order will be marked as 'Non-Verified'.
"BLD",8061,1,113,0)
 
"BLD",8061,1,114,0)
3. To verify a 'Non-Verified' CS order, PSDRPH security key is now
"BLD",8061,1,115,0)
   required.
"BLD",8061,1,116,0)
 
"BLD",8061,1,117,0)
4. To discontinue a pending CS order, PSDRPH security key is now required.
"BLD",8061,1,118,0)
 
"BLD",8061,1,119,0)
5. The pending order screen will now display the provider's DEA/VA #, the 
"BLD",8061,1,120,0)
   DETOX# (if available) and the site address.
"BLD",8061,1,121,0)
 
"BLD",8061,1,122,0)
6. When finishing a new pending CS order, the orderable item, dosage, 
"BLD",8061,1,123,0)
   provider name, or the number of refills will not be allowed to be 
"BLD",8061,1,124,0)
   edited. Also, if the changes to the dispense drug would result in
"BLD",8061,1,125,0)
   a new order being created, this will not be allowed for digitally 
"BLD",8061,1,126,0)
   signed orders. The user WILL be allowed to select other dispense drugs 
"BLD",8061,1,127,0)
   for the same Orderable Item as long as it does not change the 
"BLD",8061,1,128,0)
   prescribed dosage.
"BLD",8061,1,129,0)
 
"BLD",8061,1,130,0)
7. When finishing a new pending CS order, the days supply or the quantity
"BLD",8061,1,131,0)
   will not be allowed to increase, but can be decreased. If the days
"BLD",8061,1,132,0)
   supply is decreased, the number of refills will also be adjusted 
"BLD",8061,1,133,0)
   accordingly depending on the drug setup (maximum refills, not 
"BLD",8061,1,134,0)
   refillable etc).
"BLD",8061,1,135,0)
 
"BLD",8061,1,136,0)
8. In patch PSO*7*99, a change was made for pending orders not to 
"BLD",8061,1,137,0)
   recalculate the quantity for CS drugs on selecting a different strength
"BLD",8061,1,138,0)
   of the same drug and resulting in the same prescribed dosage. This
"BLD",8061,1,139,0)
   change is removed in this patch.
"BLD",8061,1,140,0)
 
"BLD",8061,1,141,0)
9. When finishing a pending CS order or verifying a CS order by the PSDRPH
"BLD",8061,1,142,0)
   key holder, any edit to some of the key fields like dispense drug,
"BLD",8061,1,143,0)
   dosage, dispense units, issue date, day's supply, quantity or number of
"BLD",8061,1,144,0)
   refills, will now be captured and stored in the activity log.
"BLD",8061,1,145,0)
 
"BLD",8061,1,146,0)
10. In the Complete Orders From OERR [PSO LMOE FINISH] option, a new sort 
"BLD",8061,1,147,0)
    selection, 'CS' is included to select digitally signed CS orders 
"BLD",8061,1,148,0)
    separately.
"BLD",8061,1,149,0)
 
"BLD",8061,1,150,0)
11. A new field BACKDOOR SIGNATURE STATUS (#311) is being added to the 
"BLD",8061,1,151,0)
    PRESCRIPTION file (#52) and will be set to '1' to indicate that the CS
"BLD",8061,1,152,0)
    order was entered via pharmacy backdoor and was not digitally signed.
"BLD",8061,1,153,0)
 
"BLD",8061,1,154,0)
12. A new field, DIRECTIONS FOR USE (#120) is being added to the PENDING
"BLD",8061,1,155,0)
    OUTPATIENT ORDERS file (#52.41) to store the raw HEALTH LEVEL SEVEN
"BLD",8061,1,156,0)
    (HL7) dosage data as sent from CPRS. This will be used to validate the
"BLD",8061,1,157,0)
    integrity (hash count) against the CPRS digitally signed orders.
"BLD",8061,1,158,0)
 
"BLD",8061,1,159,0)
13. Currently, the pending order screen displays only the number of 
"BLD",8061,1,160,0)
    refills ordered by the provider. For digitally signed orders, this
"BLD",8061,1,161,0)
    is modified to include the days supply and the quantity. Here is a
"BLD",8061,1,162,0)
    screen capture:
"BLD",8061,1,163,0)
    (6)    Issue Date: SEP 17,2012        (7) Fill Date: SEP 17,2012
"BLD",8061,1,164,0)
    (8)    Days Supply: 45                (9)   QTY (  ): 45
"BLD",8061,1,165,0)
   Provider ordered: days supply 45, quantity 45 & refills 1    
"BLD",8061,1,166,0)
   (10)   # of Refills: 1                (11)  Routing: WINDOW
"BLD",8061,1,167,0)
 
"BLD",8061,1,168,0)
14. The protocols PSO LM ACCEPT and PSO LM RENEW MENU are being modified
"BLD",8061,1,169,0)
    to add code to the SCREEN field (#24) and the HEADER field (#26) of
"BLD",8061,1,170,0)
    the PROTOCOL file (#101) to ensure users are limited to ListMan
"BLD",8061,1,171,0)
    actions based on their security key.
"BLD",8061,1,172,0)
 
"BLD",8061,1,173,0)
15. As part of this project, Kernel patch XU*8*580 introduced the 
"BLD",8061,1,174,0)
    following new fields to the NEW PERSON file (#200). Apart from the 
"BLD",8061,1,175,0)
    DEA#/VA# requirement, DEA further classifies what CS schedule a
"BLD",8061,1,176,0)
    provider is authorized to write. 
"BLD",8061,1,177,0)
 
"BLD",8061,1,178,0)
    55.1      SCHEDULE II NARCOTIC (S), [PS3;1]
"BLD",8061,1,179,0)
    55.2      SCHEDULE II NON-NARCOTIC (S), [PS3;2]
"BLD",8061,1,180,0)
    55.3      SCHEDULE III NARCOTIC (S), [PS3;3]
"BLD",8061,1,181,0)
    55.4      SCHEDULE III NON-NARCOTIC (S), [PS3;4]
"BLD",8061,1,182,0)
    55.5      SCHEDULE IV (S), [PS3;5]
"BLD",8061,1,183,0)
    55.6      SCHEDULE V (S), [PS3;6]
"BLD",8061,1,184,0)
 
"BLD",8061,1,185,0)
    If any one of the above fields are populated for a provider then when
"BLD",8061,1,186,0)
    placing a new order in backdoor pharmacy, the software will now check
"BLD",8061,1,187,0)
    for the drug schedule with the provider privileges. If the provider
"BLD",8061,1,188,0)
    does not have the credentials to write such orders then the software
"BLD",8061,1,189,0)
    will display a message (as shown below) and will not allow the 
"BLD",8061,1,190,0)
    selection that provider.
"BLD",8061,1,191,0)
    Example: When the provider does not have schedule 2 privileges, this
"BLD",8061,1,192,0)
    message is displayed: 
"BLD",8061,1,193,0)
    "Provider not authorized to write Federal Schedule 2 prescriptions."
"BLD",8061,1,194,0)
 
"BLD",8061,1,195,0)
16. When placing an order for a CS Detoxification drug, the software will 
"BLD",8061,1,196,0)
    now check for a valid Detoxification number for the provider. If the 
"BLD",8061,1,197,0)
    provider does not have a Detoxification number then the software will 
"BLD",8061,1,198,0)
    display a message "Provider must have a DETOX# to order this drug."
"BLD",8061,1,199,0)
 
"BLD",8061,1,200,0)
17. The Released and Unreleased Prescription Report [PSO RELEASE REPORT] 
"BLD",8061,1,201,0)
    is being modified to include CS as a selection to the input. The drug
"BLD",8061,1,202,0)
    name and CS schedule is being added to the output. Here are the
"BLD",8061,1,203,0)
    changes:                         
"BLD",8061,1,204,0)
 
"BLD",8061,1,205,0)
You are currently logged in under the CHEYENNE VAM&ROC division.
"BLD",8061,1,206,0)
Do you want to select a different division? NO// 
"BLD",8061,1,207,0)
 
"BLD",8061,1,208,0)
Do you want ONLY Unreleased Prescriptions? NO// 
"BLD",8061,1,209,0)
Include (C)S Rx only, (N)on CS Rx only, or (B)oth (C/N/B): B// Controlled 
"BLD",8061,1,210,0)
Substances Rxs Only
"BLD",8061,1,211,0)
 
"BLD",8061,1,212,0)
Select controlled substance schedules
"BLD",8061,1,213,0)
 
"BLD",8061,1,214,0)
     Select one of the following:
"BLD",8061,1,215,0)
 
"BLD",8061,1,216,0)
          1         SCHEDULES I - II
"BLD",8061,1,217,0)
          2         SCHEDULES III - V
"BLD",8061,1,218,0)
          3         SCHEDULES I - V
"BLD",8061,1,219,0)
 
"BLD",8061,1,220,0)
Select Schedule(s): 3// 
"BLD",8061,1,221,0)
 
"BLD",8061,1,222,0)
The report currently shows the count of unreleased and copay
"BLD",8061,1,223,0)
prescriptions, but not the count of released prescriptions. The report is
"BLD",8061,1,224,0)
modified with this patch to include the count of released prescriptions.
"BLD",8061,1,225,0)
 
"BLD",8061,1,226,0)
18. The following options are being modified to include the
"BLD",8061,1,227,0)
    DETOX/MAINTENANCE ID NUMBER field (#53.11) and the DEA EXPIRATION DATE
"BLD",8061,1,228,0)
    field (#747.44) of the NEW PERSON file (#200) as part of the screen. 
"BLD",8061,1,229,0)
    The DEA EXPIRATION DATE field will be prompted only if the PROVIDER
"BLD",8061,1,230,0)
    TYPE field (#53.6) of the NEW PERSON file (#200) is marked as "FEE 
"BLD",8061,1,231,0)
    BASIS".
"BLD",8061,1,232,0)
 
"BLD",8061,1,233,0)
    Add New Providers [PSO PROVIDER ADD]
"BLD",8061,1,234,0)
    Edit Provider [PSO PROVIDER EDIT]
"BLD",8061,1,235,0)
    View Provider [PSO PROVIDER INQUIRE]
"BLD",8061,1,236,0)
 
"BLD",8061,1,237,0)
19. Currently, the default days supply for all drugs is set from the DAYS 
"BLD",8061,1,238,0)
    SUPPLY field (#3) of the RX PATIENT STATUS file (#53) up to a maximum
"BLD",8061,1,239,0)
    of 90. With this project, the default for CS schedule II-V drugs will
"BLD",8061,1,240,0)
    be set to 30 or from the DAYS SUPPLY field (#3) of the RX PATIENT
"BLD",8061,1,241,0)
    STATUS file (#53) if it is less than 30. Also, the Integration Control
"BLD",8061,1,242,0)
    Registration #3278 that returns days supply (DSUP^PSOSIGDS) to CPRS is
"BLD",8061,1,243,0)
    modified to return 30 or from the DAYS SUPPLY field (#3) of the RX
"BLD",8061,1,244,0)
    PATIENT STATUS file (#53) if it is less than 30 for CS schedule II-V
"BLD",8061,1,245,0)
    drugs.
"BLD",8061,1,246,0)
 
"BLD",8061,1,247,0)
20. The pharmacy release slip portion of the Laser Label is being 
"BLD",8061,1,248,0)
    modified to include the text "(DSIG)" or "(NOT DSIG)" after the
"BLD",8061,1,249,0)
    patient's name to indicate that the prescription is digitally signed
"BLD",8061,1,250,0)
    or not digitally signed.
"BLD",8061,1,251,0)
 
"BLD",8061,1,252,0)
21. This patch addresses the issue reported in REMEDY ticket #595795, to
"BLD",8061,1,253,0)
    ensure that when editing an orderable item/dispensed drug, the 
"BLD",8061,1,254,0)
    instruction field is displayed only when editing the pending order 
"BLD",8061,1,255,0)
    and not when editing an active or non-verified order.
"BLD",8061,1,256,0)
 
"BLD",8061,1,257,0)
22. The Expire Prescriptions [PSO EXPIRE PRESCRIPTIONS] option that 
"BLD",8061,1,258,0)
    currently runs as a nightly job is being modified to check for the
"BLD",8061,1,259,0)
    Institutional DEA 'expiration date'. If the expiration date is within
"BLD",8061,1,260,0)
    30 calendar days or past expiration then a mail message will be
"BLD",8061,1,261,0)
    generated and sent to PSDMGR key holders. Here is an example when the
"BLD",8061,1,262,0)
    expiration date is within 30 days:
"BLD",8061,1,263,0)
 
"BLD",8061,1,264,0)
Subj: 500:Institutional DEA Expiration Date is about to expire  [#140331]
"BLD",8061,1,265,0)
03/20/12@11:57  3 lines
"BLD",8061,1,266,0)
From: POSTMASTER  In 'IN' basket.   Page 1  *New*
"BLD",8061,1,267,0)
-----------------------------------------------------------------------
"BLD",8061,1,268,0)
 
"BLD",8061,1,269,0)
Please update Institutional DEA Certification Date. Will expire on 
"BLD",8061,1,270,0)
3/24/12.
"BLD",8061,1,271,0)
 
"BLD",8061,1,272,0)
******************************
"BLD",8061,1,273,0)
 
"BLD",8061,1,274,0)
Here is an example when the DEA Expiration Date is past expiration date:
"BLD",8061,1,275,0)
 
"BLD",8061,1,276,0)
 
"BLD",8061,1,277,0)
Subj: 500:Institutional DEA Expiration Date has expired  [#140333]
"BLD",8061,1,278,0)
03/20/12@12:08  3 lines
"BLD",8061,1,279,0)
From: POSTMASTER  In 'IN' basket.   Page 1  *New*
"BLD",8061,1,280,0)
----------------------------------------------------------------------
"BLD",8061,1,281,0)
 
"BLD",8061,1,282,0)
Please update Institutional DEA Certification Date. Expired on 2/19/12.
"BLD",8061,1,283,0)
 
"BLD",8061,1,284,0)
**********************************
"BLD",8061,4,0)
^9.64PA^52.41^2
"BLD",8061,4,52,0)
52
"BLD",8061,4,52,2,0)
^9.641^52^1
"BLD",8061,4,52,2,52,0)
PRESCRIPTION  (File-top level)
"BLD",8061,4,52,2,52,1,0)
^9.6411^311^1
"BLD",8061,4,52,2,52,1,311,0)
BACKDOOR SIGNATURE STATUS
"BLD",8061,4,52,222)
y^n^p^^^^n^^n
"BLD",8061,4,52,224)

"BLD",8061,4,52.41,0)
52.41
"BLD",8061,4,52.41,2,0)
^9.641^52.41^2
"BLD",8061,4,52.41,2,52.41,0)
PENDING OUTPATIENT ORDERS  (File-top level)
"BLD",8061,4,52.41,2,52.41,1,0)
^9.6411^118^1
"BLD",8061,4,52.41,2,52.41,1,118,0)
DRUG INCLUDED
"BLD",8061,4,52.41,2,52.44,0)
DIRECTIONS FOR USE  (sub-file)
"BLD",8061,4,52.41,2,52.44,1,0)
^9.6411^^0
"BLD",8061,4,52.41,222)
y^n^p^^^^n^^n
"BLD",8061,4,52.41,224)

"BLD",8061,4,"APDD",52,52)

"BLD",8061,4,"APDD",52,52,311)

"BLD",8061,4,"APDD",52.41,52.41)

"BLD",8061,4,"APDD",52.41,52.41,118)

"BLD",8061,4,"APDD",52.41,52.44)

"BLD",8061,4,"B",52,52)

"BLD",8061,4,"B",52.41,52.41)

"BLD",8061,6)
13^
"BLD",8061,6.3)
13
"BLD",8061,"ABPKG")
n
"BLD",8061,"KRN",0)
^9.67PA^779.2^20
"BLD",8061,"KRN",.4,0)
.4
"BLD",8061,"KRN",.401,0)
.401
"BLD",8061,"KRN",.402,0)
.402
"BLD",8061,"KRN",.403,0)
.403
"BLD",8061,"KRN",.5,0)
.5
"BLD",8061,"KRN",.84,0)
.84
"BLD",8061,"KRN",3.6,0)
3.6
"BLD",8061,"KRN",3.8,0)
3.8
"BLD",8061,"KRN",9.2,0)
9.2
"BLD",8061,"KRN",9.8,0)
9.8
"BLD",8061,"KRN",9.8,"NM",0)
^9.68A^44^33
"BLD",8061,"KRN",9.8,"NM",2,0)
PSOORFIN^^0^B63039564
"BLD",8061,"KRN",9.8,"NM",10,0)
PSOORFI5^^0^B46664581
"BLD",8061,"KRN",9.8,"NM",11,0)
PSOORFI1^^0^B83482862
"BLD",8061,"KRN",9.8,"NM",12,0)
PSOVER^^0^B81192424
"BLD",8061,"KRN",9.8,"NM",14,0)
PSON52^^0^B86376192
"BLD",8061,"KRN",9.8,"NM",15,0)
PSOORNEW^^0^B92744719
"BLD",8061,"KRN",9.8,"NM",16,0)
PSOPKIV1^^0^B98820890
"BLD",8061,"KRN",9.8,"NM",17,0)
PSOORNE5^^0^B68801944
"BLD",8061,"KRN",9.8,"NM",18,0)
PSODIR^^0^B34162228
"BLD",8061,"KRN",9.8,"NM",19,0)
PSOHLEXP^^0^B22400492
"BLD",8061,"KRN",9.8,"NM",20,0)
PSODISP1^^0^B49194938
"BLD",8061,"KRN",9.8,"NM",22,0)
PSOOREDT^^0^B72615864
"BLD",8061,"KRN",9.8,"NM",23,0)
PSOORNE4^^0^B94257859
"BLD",8061,"KRN",9.8,"NM",24,0)
PSOORNE2^^0^B69776712
"BLD",8061,"KRN",9.8,"NM",25,0)
PSOORNE3^^0^B68130643
"BLD",8061,"KRN",9.8,"NM",26,0)
PSORXVW^^0^B77494288
"BLD",8061,"KRN",9.8,"NM",27,0)
PSOCAN4^^0^B49357876
"BLD",8061,"KRN",9.8,"NM",28,0)
PSOPKIV2^^0^B23465178
"BLD",8061,"KRN",9.8,"NM",29,0)
PSODGDGP^^0^B66741905
"BLD",8061,"KRN",9.8,"NM",31,0)
PSOORFI4^^0^B81023299
"BLD",8061,"KRN",9.8,"NM",32,0)
PSONFI^^0^B8543831
"BLD",8061,"KRN",9.8,"NM",33,0)
PSOSIG^^0^B70011572
"BLD",8061,"KRN",9.8,"NM",34,0)
PSOPRVW^^0^B40061242
"BLD",8061,"KRN",9.8,"NM",35,0)
PSODIR1^^0^B94639325
"BLD",8061,"KRN",9.8,"NM",36,0)
PSOSIGDS^^0^B68186224
"BLD",8061,"KRN",9.8,"NM",37,0)
PSOORNW1^^0^B44718806
"BLD",8061,"KRN",9.8,"NM",38,0)
PSOORED4^^0^B54971624
"BLD",8061,"KRN",9.8,"NM",39,0)
PSOHLNEW^^0^B86108957
"BLD",8061,"KRN",9.8,"NM",40,0)
PSOHLNE1^^0^B74363469
"BLD",8061,"KRN",9.8,"NM",41,0)
PSOHLNE2^^0^B64216422
"BLD",8061,"KRN",9.8,"NM",42,0)
PSOLLL2^^0^B16898415
"BLD",8061,"KRN",9.8,"NM",43,0)
PSODISP^^0^B53119721
"BLD",8061,"KRN",9.8,"NM",44,0)
PSORN52C^^0^B68196793
"BLD",8061,"KRN",9.8,"NM","B","PSOCAN4",27)

"BLD",8061,"KRN",9.8,"NM","B","PSODGDGP",29)

"BLD",8061,"KRN",9.8,"NM","B","PSODIR",18)

"BLD",8061,"KRN",9.8,"NM","B","PSODIR1",35)

"BLD",8061,"KRN",9.8,"NM","B","PSODISP",43)

"BLD",8061,"KRN",9.8,"NM","B","PSODISP1",20)

"BLD",8061,"KRN",9.8,"NM","B","PSOHLEXP",19)

"BLD",8061,"KRN",9.8,"NM","B","PSOHLNE1",40)

"BLD",8061,"KRN",9.8,"NM","B","PSOHLNE2",41)

"BLD",8061,"KRN",9.8,"NM","B","PSOHLNEW",39)

"BLD",8061,"KRN",9.8,"NM","B","PSOLLL2",42)

"BLD",8061,"KRN",9.8,"NM","B","PSON52",14)

"BLD",8061,"KRN",9.8,"NM","B","PSONFI",32)

"BLD",8061,"KRN",9.8,"NM","B","PSOORED4",38)

"BLD",8061,"KRN",9.8,"NM","B","PSOOREDT",22)

"BLD",8061,"KRN",9.8,"NM","B","PSOORFI1",11)

"BLD",8061,"KRN",9.8,"NM","B","PSOORFI4",31)

"BLD",8061,"KRN",9.8,"NM","B","PSOORFI5",10)

"BLD",8061,"KRN",9.8,"NM","B","PSOORFIN",2)

"BLD",8061,"KRN",9.8,"NM","B","PSOORNE2",24)

"BLD",8061,"KRN",9.8,"NM","B","PSOORNE3",25)

"BLD",8061,"KRN",9.8,"NM","B","PSOORNE4",23)

"BLD",8061,"KRN",9.8,"NM","B","PSOORNE5",17)

"BLD",8061,"KRN",9.8,"NM","B","PSOORNEW",15)

"BLD",8061,"KRN",9.8,"NM","B","PSOORNW1",37)

"BLD",8061,"KRN",9.8,"NM","B","PSOPKIV1",16)

"BLD",8061,"KRN",9.8,"NM","B","PSOPKIV2",28)

"BLD",8061,"KRN",9.8,"NM","B","PSOPRVW",34)

"BLD",8061,"KRN",9.8,"NM","B","PSORN52C",44)

"BLD",8061,"KRN",9.8,"NM","B","PSORXVW",26)

"BLD",8061,"KRN",9.8,"NM","B","PSOSIG",33)

"BLD",8061,"KRN",9.8,"NM","B","PSOSIGDS",36)

"BLD",8061,"KRN",9.8,"NM","B","PSOVER",12)

"BLD",8061,"KRN",19,0)
19
"BLD",8061,"KRN",19,"NM",0)
^9.68A^^
"BLD",8061,"KRN",19.1,0)
19.1
"BLD",8061,"KRN",101,0)
101
"BLD",8061,"KRN",101,"NM",0)
^9.68A^9^9
"BLD",8061,"KRN",101,"NM",1,0)
PSO LM ACCEPT^^0
"BLD",8061,"KRN",101,"NM",2,0)
PSO LM RENEW MENU^^0
"BLD",8061,"KRN",101,"NM",3,0)
PSO LM DISCONTINUE^^0
"BLD",8061,"KRN",101,"NM",4,0)
PSO LM EDIT^^0
"BLD",8061,"KRN",101,"NM",5,0)
PSO LM ACCEPT ORDER^^0
"BLD",8061,"KRN",101,"NM",6,0)
PSO LM RENEW ACCEPT^^0
"BLD",8061,"KRN",101,"NM",7,0)
PSO LM RENEW EDIT^^0
"BLD",8061,"KRN",101,"NM",8,0)
PSO LM BYPASS^^0
"BLD",8061,"KRN",101,"NM",9,0)
PSO LM FLAG^^0
"BLD",8061,"KRN",101,"NM","B","PSO LM ACCEPT",1)

"BLD",8061,"KRN",101,"NM","B","PSO LM ACCEPT ORDER",5)

"BLD",8061,"KRN",101,"NM","B","PSO LM BYPASS",8)

"BLD",8061,"KRN",101,"NM","B","PSO LM DISCONTINUE",3)

"BLD",8061,"KRN",101,"NM","B","PSO LM EDIT",4)

"BLD",8061,"KRN",101,"NM","B","PSO LM FLAG",9)

"BLD",8061,"KRN",101,"NM","B","PSO LM RENEW ACCEPT",6)

"BLD",8061,"KRN",101,"NM","B","PSO LM RENEW EDIT",7)

"BLD",8061,"KRN",101,"NM","B","PSO LM RENEW MENU",2)

"BLD",8061,"KRN",409.61,0)
409.61
"BLD",8061,"KRN",409.61,"NM",0)
^9.68A^^0
"BLD",8061,"KRN",771,0)
771
"BLD",8061,"KRN",779.2,0)
779.2
"BLD",8061,"KRN",870,0)
870
"BLD",8061,"KRN",8989.51,0)
8989.51
"BLD",8061,"KRN",8989.52,0)
8989.52
"BLD",8061,"KRN",8994,0)
8994
"BLD",8061,"KRN","B",.4,.4)

"BLD",8061,"KRN","B",.401,.401)

"BLD",8061,"KRN","B",.402,.402)

"BLD",8061,"KRN","B",.403,.403)

"BLD",8061,"KRN","B",.5,.5)

"BLD",8061,"KRN","B",.84,.84)

"BLD",8061,"KRN","B",3.6,3.6)

"BLD",8061,"KRN","B",3.8,3.8)

"BLD",8061,"KRN","B",9.2,9.2)

"BLD",8061,"KRN","B",9.8,9.8)

"BLD",8061,"KRN","B",19,19)

"BLD",8061,"KRN","B",19.1,19.1)

"BLD",8061,"KRN","B",101,101)

"BLD",8061,"KRN","B",409.61,409.61)

"BLD",8061,"KRN","B",771,771)

"BLD",8061,"KRN","B",779.2,779.2)

"BLD",8061,"KRN","B",870,870)

"BLD",8061,"KRN","B",8989.51,8989.51)

"BLD",8061,"KRN","B",8989.52,8989.52)

"BLD",8061,"KRN","B",8994,8994)

"BLD",8061,"QDEF")
^^^^NO^^^^NO^^NO
"BLD",8061,"QUES",0)
^9.62^^
"BLD",8061,"REQB",0)
^9.611^14^9
"BLD",8061,"REQB",4,0)
PSO*7.0*194^2
"BLD",8061,"REQB",6,0)
XU*8.0*580^2
"BLD",8061,"REQB",7,0)
PSD*3.0*76^2
"BLD",8061,"REQB",8,0)
PSS*1.0*166^2
"BLD",8061,"REQB",9,0)
PSO*7.0*377^2
"BLD",8061,"REQB",10,0)
PSO*7.0*257^2
"BLD",8061,"REQB",11,0)
PSO*7.0*390^2
"BLD",8061,"REQB",12,0)
PSO*7.0*340^2
"BLD",8061,"REQB",14,0)
PSO*7.0*400^2
"BLD",8061,"REQB","B","PSD*3.0*76",7)

"BLD",8061,"REQB","B","PSO*7.0*194",4)

"BLD",8061,"REQB","B","PSO*7.0*257",10)

"BLD",8061,"REQB","B","PSO*7.0*340",12)

"BLD",8061,"REQB","B","PSO*7.0*377",9)

"BLD",8061,"REQB","B","PSO*7.0*390",11)

"BLD",8061,"REQB","B","PSO*7.0*400",14)

"BLD",8061,"REQB","B","PSS*1.0*166",8)

"BLD",8061,"REQB","B","XU*8.0*580",6)

"FIA",52)
PRESCRIPTION
"FIA",52,0)
^PSRX(
"FIA",52,0,0)
52Is
"FIA",52,0,1)
y^n^p^^^^n^^n
"FIA",52,0,10)

"FIA",52,0,11)

"FIA",52,0,"RLRO")

"FIA",52,0,"VR")
7.0^PSO
"FIA",52,52)
1
"FIA",52,52,311)

"FIA",52.41)
PENDING OUTPATIENT ORDERS
"FIA",52.41,0)
^PS(52.41,
"FIA",52.41,0,0)
52.41I
"FIA",52.41,0,1)
y^n^p^^^^n^^n
"FIA",52.41,0,10)

"FIA",52.41,0,11)

"FIA",52.41,0,"RLRO")

"FIA",52.41,0,"VR")
7.0^PSO
"FIA",52.41,52.41)
1
"FIA",52.41,52.41,118)

"FIA",52.41,52.41,120)

"FIA",52.41,52.44)
0
"KRN",101,3781,-1)
0^3
"KRN",101,3781,0)
PSO LM DISCONTINUE^Discontinue^^A^^^^^^^^OUTPATIENT PHARMACY
"KRN",101,3781,15)
D KCAN^PSOCAN3 W ""
"KRN",101,3781,20)
S (PSOCANRA,PSOCANRP)=1 D DC^PSOORFI2
"KRN",101,3781,99)
59450,31436
"KRN",101,3792,-1)
0^8
"KRN",101,3792,0)
PSO LM BYPASS^Bypass^^A^^^^^^^^OUTPATIENT PHARMACY
"KRN",101,3792,15)

"KRN",101,3792,20)
S VALMBCK="" D BYPASS^PSOLMUTL
"KRN",101,3792,99)
59450,31436
"KRN",101,3794,-1)
0^4
"KRN",101,3794,0)
PSO LM EDIT^Edit^^A^^^^^^^^OUTPATIENT PHARMACY
"KRN",101,3794,15)

"KRN",101,3794,20)
D EDT^PSOORNEW
"KRN",101,3794,99)
58715,57588
"KRN",101,3802,-1)
0^1
"KRN",101,3802,0)
PSO LM ACCEPT^ACCEPT ORDER FOR FINISH^^M^^^^^^^^OUTPATIENT PHARMACY
"KRN",101,3802,4)
25^3
"KRN",101,3802,10,0)
^101.01PA^3^3
"KRN",101,3802,10,1,0)
3794^ED^21^
"KRN",101,3802,10,1,"^")
PSO LM EDIT
"KRN",101,3802,10,2,0)
3803^AC^11^
"KRN",101,3802,10,2,"^")
PSO LM ACCEPT ORDER
"KRN",101,3802,10,3,0)
3781^DC^31^
"KRN",101,3802,10,3,"^")
PSO LM DISCONTINUE
"KRN",101,3802,15)

"KRN",101,3802,24)
I $$ACTIONS1^PSOLMUTL
"KRN",101,3802,26)
D A^PSOORUT3,SHOW^VALM S:$G(PSOACT)["E" XQORM("#")=$O(^ORD(101,"B","PSO LM PENDING EDIT",0))_"^1:15" S:XQORM("B")="Quit" XQORM("B")="Edit"
"KRN",101,3802,99)
62724,37160
"KRN",101,3803,-1)
0^5
"KRN",101,3803,0)
PSO LM ACCEPT ORDER^Accept^^A^^^^^^^^OUTPATIENT PHARMACY
"KRN",101,3803,2,0)
^101.02A^1^1
"KRN",101,3803,2,1,0)
AC
"KRN",101,3803,2,"B","AC",1)

"KRN",101,3803,15)

"KRN",101,3803,20)
G ACP^PSOORNEW
"KRN",101,3803,99)
57603,35835
"KRN",101,3812,-1)
0^7
"KRN",101,3812,0)
PSO LM RENEW EDIT^Edit^^A^^^^^^^^OUTPATIENT PHARMACY
"KRN",101,3812,20)
D EDT^PSOORNE4
"KRN",101,3812,99)
59450,31436
"KRN",101,3813,-1)
0^6
"KRN",101,3813,0)
PSO LM RENEW ACCEPT^Accept^^A^^^^^^^^OUTPATIENT PHARMACY
"KRN",101,3813,15)
S VALMBCK="Q"
"KRN",101,3813,20)
D ACP^PSOORNE4
"KRN",101,3813,99)
59450,31436
"KRN",101,3814,-1)
0^2
"KRN",101,3814,0)
PSO LM RENEW MENU^Rx Renew^^M^^^^^^^^OUTPATIENT PHARMACY
"KRN",101,3814,4)
26
"KRN",101,3814,10,0)
^101.01PA^5^5
"KRN",101,3814,10,1,0)
3813^AC^^
"KRN",101,3814,10,1,"^")
PSO LM RENEW ACCEPT
"KRN",101,3814,10,2,0)
3812^ED^^
"KRN",101,3814,10,2,"^")
PSO LM RENEW EDIT
"KRN",101,3814,10,3,0)
3781^DC^^
"KRN",101,3814,10,3,"^")
PSO LM DISCONTINUE
"KRN",101,3814,10,4,0)
3792^BY^^
"KRN",101,3814,10,4,"^")
PSO LM BYPASS
"KRN",101,3814,10,5,0)
5681^FL^^
"KRN",101,3814,10,5,"^")
PSO LM FLAG
"KRN",101,3814,15)
K PSOLM
"KRN",101,3814,20)
S PSOLM=1
"KRN",101,3814,24)
I $$PKIACT^PSOLMUTL
"KRN",101,3814,26)
D A^PSOORUT3,SHOW^VALM S:$G(PSOACT)["E" XQORM("#")=$O(^ORD(101,"B","PSO LM RNEW EDIT",0))_"^1:"_$S($G(PSOREEDT):10,1:8)
"KRN",101,3814,99)
62724,37160
"KRN",101,5681,-1)
0^9
"KRN",101,5681,0)
PSO LM FLAG^Flag/Unflag^^A^^^^^^^^OUTPATIENT PHARMACY
"KRN",101,5681,1,0)
^101.06^2^2^3120523^^^^
"KRN",101,5681,1,1,0)
This option allows the user to flag/unflag an Outpatient Pharmacy 
"KRN",101,5681,1,2,0)
prescription.
"KRN",101,5681,2,0)
^101.02A^1^1
"KRN",101,5681,2,1,0)
FL
"KRN",101,5681,2,"B","FL",1)

"KRN",101,5681,15)

"KRN",101,5681,20)
D FLAG^PSOORFL
"KRN",101,5681,99)
61229,37773
"MBREQ")
0
"ORD",15,101)
101;15;;;PRO^XPDTA;PROF1^XPDIA;PROE1^XPDIA;PROF2^XPDIA;;PRODEL^XPDIA
"ORD",15,101,0)
PROTOCOL
"PKG",141,-1)
1^1
"PKG",141,0)
OUTPATIENT PHARMACY^PSO^OUTPATIENT LABELS, PROFILE, INVENTORY, PRESCRIPTIONS
"PKG",141,20,0)
^9.402P^^
"PKG",141,22,0)
^9.49I^1^1
"PKG",141,22,1,0)
7.0^2971216^2980917^11712
"PKG",141,22,1,"PAH",1,0)
391^3130329
"PKG",141,22,1,"PAH",1,1,0)
^^284^284^3130329
"PKG",141,22,1,"PAH",1,1,1,0)
This patch is being released as part of the DEA e-Prescribing of
"PKG",141,22,1,"PAH",1,1,2,0)
Controlled Substances (CS) project using Public Key Infrastructure (PKI)
"PKG",141,22,1,"PAH",1,1,3,0)
to satisfy requirements requested by the Drug Enforcement Administration
"PKG",141,22,1,"PAH",1,1,4,0)
(DEA).
"PKG",141,22,1,"PAH",1,1,5,0)
The applications involved in this project along with their patch numbers 
"PKG",141,22,1,"PAH",1,1,6,0)
are listed below and the same order should be followed when installing 
"PKG",141,22,1,"PAH",1,1,7,0)
the patches.
"PKG",141,22,1,"PAH",1,1,8,0)
 
"PKG",141,22,1,"PAH",1,1,9,0)
   APPLICATION                                            PATCH
"PKG",141,22,1,"PAH",1,1,10,0)
   -----------------------------------------------------------------
"PKG",141,22,1,"PAH",1,1,11,0)
   KERNEL V. 8.0                                          XU*8*580
"PKG",141,22,1,"PAH",1,1,12,0)
   PHARMACY DATA MANAGEMENT (PDM) V. 1.0                  PSS*1*166
"PKG",141,22,1,"PAH",1,1,13,0)
   COMPUTERIZED PATIENT RECORD SYSTEM (CPRS) V. 3.0       OR*3*306
"PKG",141,22,1,"PAH",1,1,14,0)
   CONTROLLED SUBSTANCES (CS) V. 3.0                      PSD*3*73
"PKG",141,22,1,"PAH",1,1,15,0)
   OUTPATIENT PHARMACY (OP) V. 7.0                        PSO*7*391
"PKG",141,22,1,"PAH",1,1,16,0)
 
"PKG",141,22,1,"PAH",1,1,17,0)
Note:
"PKG",141,22,1,"PAH",1,1,18,0)
1. A new security key named "PSDRPH", has been sent out in the Controlled
"PKG",141,22,1,"PAH",1,1,19,0)
   Substances patch PSD*3*76, which is a required patch for this patch.
"PKG",141,22,1,"PAH",1,1,20,0)
   This key authorizes pharmacists to finish/verify a digitally signed
"PKG",141,22,1,"PAH",1,1,21,0)
   Schedule II-V CS orders placed via CPRS and should be assigned to
"PKG",141,22,1,"PAH",1,1,22,0)
   registered pharmacists working with Schedule II-V drugs.
"PKG",141,22,1,"PAH",1,1,23,0)
 
"PKG",141,22,1,"PAH",1,1,24,0)
2. Patches PSO*7*391 and PSD*3*73 are being released in the Kernel 
"PKG",141,22,1,"PAH",1,1,25,0)
   Installation and Distribution System (KIDS) multi-build distribution
"PKG",141,22,1,"PAH",1,1,26,0)
   CPRSV29_PSO_PSD. 
"PKG",141,22,1,"PAH",1,1,27,0)
 
"PKG",141,22,1,"PAH",1,1,28,0)
The following modifications and enhancements are included in this patch 
"PKG",141,22,1,"PAH",1,1,29,0)
(PSO*7*391):
"PKG",141,22,1,"PAH",1,1,30,0)
 
"PKG",141,22,1,"PAH",1,1,31,0)
1. When processing a digitally signed pending order, the integrity of the 
"PKG",141,22,1,"PAH",1,1,32,0)
original order placed in CPRS is now being checked to ensure that the data
"PKG",141,22,1,"PAH",1,1,33,0)
fields listed below are not altered from the time the order is signed in
"PKG",141,22,1,"PAH",1,1,34,0)
CPRS and later selected for processing in backdoor pharmacy. This is done
"PKG",141,22,1,"PAH",1,1,35,0)
by passing the data elements listed below to a Kernel Application
"PKG",141,22,1,"PAH",1,1,36,0)
Programming Interface (API), Integration Control Registration (ICR) #3539,
"PKG",141,22,1,"PAH",1,1,37,0)
along with the CPRS hash count, provided by ICR #5709. The Kernel API
"PKG",141,22,1,"PAH",1,1,38,0)
compares these two hash values and returns an "OK" if the pending order is
"PKG",141,22,1,"PAH",1,1,39,0)
unaltered or otherwise, returns a "-1^error code^error message."
"PKG",141,22,1,"PAH",1,1,40,0)
 
"PKG",141,22,1,"PAH",1,1,41,0)
Example: "-1^89802016^Mismatched digital signature hash values."
"PKG",141,22,1,"PAH",1,1,42,0)
 
"PKG",141,22,1,"PAH",1,1,43,0)
These are the fields used in the hash check:
"PKG",141,22,1,"PAH",1,1,44,0)
        Date of Issuance
"PKG",141,22,1,"PAH",1,1,45,0)
        Full Name and Address of the Patient
"PKG",141,22,1,"PAH",1,1,46,0)
        Drug Name
"PKG",141,22,1,"PAH",1,1,47,0)
        Quantity Prescribed  
"PKG",141,22,1,"PAH",1,1,48,0)
        Directions for Use
"PKG",141,22,1,"PAH",1,1,49,0)
        Prescriber Name   
"PKG",141,22,1,"PAH",1,1,50,0)
        Prescriber Address (site address) 
"PKG",141,22,1,"PAH",1,1,51,0)
        Prescriber DEA / VA Registration Number
"PKG",141,22,1,"PAH",1,1,52,0)
        Order Number (CPRS)
"PKG",141,22,1,"PAH",1,1,53,0)
 
"PKG",141,22,1,"PAH",1,1,54,0)
The Kernel API will also check for the validity of the DEA certificate. If
"PKG",141,22,1,"PAH",1,1,55,0)
the certificate is revoked or expired then the API will return the
"PKG",141,22,1,"PAH",1,1,56,0)
appropriate error code.
"PKG",141,22,1,"PAH",1,1,57,0)
If the error code is related to hash mismatch or the DEA certificate is
"PKG",141,22,1,"PAH",1,1,58,0)
revoked then the following events will be triggered during pending order
"PKG",141,22,1,"PAH",1,1,59,0)
processing:
"PKG",141,22,1,"PAH",1,1,60,0)
  The order will be auto discontinued.
"PKG",141,22,1,"PAH",1,1,61,0)
  First line of the pending order screen will have the message "Digital
"PKG",141,22,1,"PAH",1,1,62,0)
  Signature Failed: Corrupted (Hash mismatch)" or "Certificate revoked"
"PKG",141,22,1,"PAH",1,1,63,0)
  concatenated with "Order Auto Discontinued", and the message will be
"PKG",141,22,1,"PAH",1,1,64,0)
  highlighted in reverse video.
"PKG",141,22,1,"PAH",1,1,65,0)
  The status bar of the screen will have the message "Signature Failed: 
"PKG",141,22,1,"PAH",1,1,66,0)
  Corrupted (Hash mismatch)" or Certificate revoked."
"PKG",141,22,1,"PAH",1,1,67,0)
  A mail message will be generated to the holders of the PSDMGR key 
"PKG",141,22,1,"PAH",1,1,68,0)
  notifying that the order has been auto discontinued (similar to the 
"PKG",141,22,1,"PAH",1,1,69,0)
  example listed below).
"PKG",141,22,1,"PAH",1,1,70,0)
  If the discontinuation is due to a hash mismatch as a result of altering
"PKG",141,22,1,"PAH",1,1,71,0)
  one of the fields listed above then the mail message will show the
"PKG",141,22,1,"PAH",1,1,72,0)
  altered fields with the discrepancies. Here is an example:
"PKG",141,22,1,"PAH",1,1,73,0)
 
"PKG",141,22,1,"PAH",1,1,74,0)
  Subj: DIGITALLY SIGNED NEW ORDER AUTO DISCONTINUED  [#196353] 
"PKG",141,22,1,"PAH",1,1,75,0)
        03/20/12@17:1024 lines
"PKG",141,22,1,"PAH",1,1,76,0)
  From: POSTMASTER  In 'IN' basket.   Page 1  *New*
"PKG",141,22,1,"PAH",1,1,77,0)
         
"PKG",141,22,1,"PAH",1,1,78,0)
  -----------------------------------------------------------------------
"PKG",141,22,1,"PAH",1,1,79,0)
 
"PKG",141,22,1,"PAH",1,1,80,0)
  Following order was auto discontinued when finishing a pending order   
"PKG",141,22,1,"PAH",1,1,81,0)
  due to Corrupted (Hash mismatch) - 89802016
"PKG",141,22,1,"PAH",1,1,82,0)
 
"PKG",141,22,1,"PAH",1,1,83,0)
  Division      : GREELEY CLINIC
"PKG",141,22,1,"PAH",1,1,84,0)
  CPRS Order #  : 5587651
"PKG",141,22,1,"PAH",1,1,85,0)
  Issue Date    : MAR 7,2012
"PKG",141,22,1,"PAH",1,1,86,0)
  Patient       : TEST,PATIENT (0908)
"PKG",141,22,1,"PAH",1,1,87,0)
  Address       : P.O. BOX 31
"PKG",141,22,1,"PAH",1,1,88,0)
                  LAPORTE, CA  95981
"PKG",141,22,1,"PAH",1,1,89,0)
  Drug          : CODEINE SULFATE 60MG TAB
"PKG",141,22,1,"PAH",1,1,90,0)
  Dosage Ordered: 120(MG)
"PKG",141,22,1,"PAH",1,1,91,0)
  Dosage Form   : TABLETS
"PKG",141,22,1,"PAH",1,1,92,0)
  Quantity      : 54
"PKG",141,22,1,"PAH",1,1,93,0)
  Provider      : TEST,PROVIDER
"PKG",141,22,1,"PAH",1,1,94,0)
  DEA#          : TA1234563
"PKG",141,22,1,"PAH",1,1,95,0)
  Site Address  : 2360 E PERSHING BLVD
"PKG",141,22,1,"PAH",1,1,96,0)
                  2360 East Pershing Boulevard
"PKG",141,22,1,"PAH",1,1,97,0)
                  CHEYENNE
"PKG",141,22,1,"PAH",1,1,98,0)
 
"PKG",141,22,1,"PAH",1,1,99,0)
  Differences in CPRS and Pharmacy Pending File
"PKG",141,22,1,"PAH",1,1,100,0)
 
"PKG",141,22,1,"PAH",1,1,101,0)
  Data Name           CPRS File         Pharmacy Pending File
"PKG",141,22,1,"PAH",1,1,102,0)
  ---------           ---------         ---------------------
"PKG",141,22,1,"PAH",1,1,103,0)
  QTY PRESCRIBED      15                30
"PKG",141,22,1,"PAH",1,1,104,0)
 
"PKG",141,22,1,"PAH",1,1,105,0)
         
"PKG",141,22,1,"PAH",1,1,106,0)
  If the error code is related to 'certificate expired', the pending 
"PKG",141,22,1,"PAH",1,1,107,0)
  order will be processed (will not be auto discontinued) and a 
"PKG",141,22,1,"PAH",1,1,108,0)
  notification will be sent to the provider with the message, "DEA
"PKG",141,22,1,"PAH",1,1,109,0)
  certificate expired. Renew your certificate."
"PKG",141,22,1,"PAH",1,1,110,0)
 
"PKG",141,22,1,"PAH",1,1,111,0)
2. When finishing a pending CS order, if the user does not hold the new 
"PKG",141,22,1,"PAH",1,1,112,0)
   PSDRPH security key, the order will be marked as 'Non-Verified'.
"PKG",141,22,1,"PAH",1,1,113,0)
 
"PKG",141,22,1,"PAH",1,1,114,0)
3. To verify a 'Non-Verified' CS order, PSDRPH security key is now
"PKG",141,22,1,"PAH",1,1,115,0)
   required.
"PKG",141,22,1,"PAH",1,1,116,0)
 
"PKG",141,22,1,"PAH",1,1,117,0)
4. To discontinue a pending CS order, PSDRPH security key is now required.
"PKG",141,22,1,"PAH",1,1,118,0)
 
"PKG",141,22,1,"PAH",1,1,119,0)
5. The pending order screen will now display the provider's DEA/VA #, the 
"PKG",141,22,1,"PAH",1,1,120,0)
   DETOX# (if available) and the site address.
"PKG",141,22,1,"PAH",1,1,121,0)
 
"PKG",141,22,1,"PAH",1,1,122,0)
6. When finishing a new pending CS order, the orderable item, dosage, 
"PKG",141,22,1,"PAH",1,1,123,0)
   provider name, or the number of refills will not be allowed to be 
"PKG",141,22,1,"PAH",1,1,124,0)
   edited. Also, if the changes to the dispense drug would result in
"PKG",141,22,1,"PAH",1,1,125,0)
   a new order being created, this will not be allowed for digitally 
"PKG",141,22,1,"PAH",1,1,126,0)
   signed orders. The user WILL be allowed to select other dispense drugs 
"PKG",141,22,1,"PAH",1,1,127,0)
   for the same Orderable Item as long as it does not change the 
"PKG",141,22,1,"PAH",1,1,128,0)
   prescribed dosage.
"PKG",141,22,1,"PAH",1,1,129,0)
 
"PKG",141,22,1,"PAH",1,1,130,0)
7. When finishing a new pending CS order, the days supply or the quantity
"PKG",141,22,1,"PAH",1,1,131,0)
   will not be allowed to increase, but can be decreased. If the days
"PKG",141,22,1,"PAH",1,1,132,0)
   supply is decreased, the number of refills will also be adjusted 
"PKG",141,22,1,"PAH",1,1,133,0)
   accordingly depending on the drug setup (maximum refills, not 
"PKG",141,22,1,"PAH",1,1,134,0)
   refillable etc).
"PKG",141,22,1,"PAH",1,1,135,0)
 
"PKG",141,22,1,"PAH",1,1,136,0)
8. In patch PSO*7*99, a change was made for pending orders not to 
"PKG",141,22,1,"PAH",1,1,137,0)
   recalculate the quantity for CS drugs on selecting a different strength
"PKG",141,22,1,"PAH",1,1,138,0)
   of the same drug and resulting in the same prescribed dosage. This
"PKG",141,22,1,"PAH",1,1,139,0)
   change is removed in this patch.
"PKG",141,22,1,"PAH",1,1,140,0)
 
"PKG",141,22,1,"PAH",1,1,141,0)
9. When finishing a pending CS order or verifying a CS order by the PSDRPH
"PKG",141,22,1,"PAH",1,1,142,0)
   key holder, any edit to some of the key fields like dispense drug,
"PKG",141,22,1,"PAH",1,1,143,0)
   dosage, dispense units, issue date, day's supply, quantity or number of
"PKG",141,22,1,"PAH",1,1,144,0)
   refills, will now be captured and stored in the activity log.
"PKG",141,22,1,"PAH",1,1,145,0)
 
"PKG",141,22,1,"PAH",1,1,146,0)
10. In the Complete Orders From OERR [PSO LMOE FINISH] option, a new sort 
"PKG",141,22,1,"PAH",1,1,147,0)
    selection, 'CS' is included to select digitally signed CS orders 
"PKG",141,22,1,"PAH",1,1,148,0)
    separately.
"PKG",141,22,1,"PAH",1,1,149,0)
 
"PKG",141,22,1,"PAH",1,1,150,0)
11. A new field BACKDOOR SIGNATURE STATUS (#311) is being added to the 
"PKG",141,22,1,"PAH",1,1,151,0)
    PRESCRIPTION file (#52) and will be set to '1' to indicate that the CS
"PKG",141,22,1,"PAH",1,1,152,0)
    order was entered via pharmacy backdoor and was not digitally signed.
"PKG",141,22,1,"PAH",1,1,153,0)
 
"PKG",141,22,1,"PAH",1,1,154,0)
12. A new field, DIRECTIONS FOR USE (#120) is being added to the PENDING
"PKG",141,22,1,"PAH",1,1,155,0)
    OUTPATIENT ORDERS file (#52.41) to store the raw HEALTH LEVEL SEVEN
"PKG",141,22,1,"PAH",1,1,156,0)
    (HL7) dosage data as sent from CPRS. This will be used to validate the
"PKG",141,22,1,"PAH",1,1,157,0)
    integrity (hash count) against the CPRS digitally signed orders.
"PKG",141,22,1,"PAH",1,1,158,0)
 
"PKG",141,22,1,"PAH",1,1,159,0)
13. Currently, the pending order screen displays only the number of 
"PKG",141,22,1,"PAH",1,1,160,0)
    refills ordered by the provider. For digitally signed orders, this
"PKG",141,22,1,"PAH",1,1,161,0)
    is modified to include the days supply and the quantity. Here is a
"PKG",141,22,1,"PAH",1,1,162,0)
    screen capture:
"PKG",141,22,1,"PAH",1,1,163,0)
    (6)    Issue Date: SEP 17,2012        (7) Fill Date: SEP 17,2012
"PKG",141,22,1,"PAH",1,1,164,0)
    (8)    Days Supply: 45                (9)   QTY (  ): 45
"PKG",141,22,1,"PAH",1,1,165,0)
   Provider ordered: days supply 45, quantity 45 & refills 1    
"PKG",141,22,1,"PAH",1,1,166,0)
   (10)   # of Refills: 1                (11)  Routing: WINDOW
"PKG",141,22,1,"PAH",1,1,167,0)
 
"PKG",141,22,1,"PAH",1,1,168,0)
14. The protocols PSO LM ACCEPT and PSO LM RENEW MENU are being modified
"PKG",141,22,1,"PAH",1,1,169,0)
    to add code to the SCREEN field (#24) and the HEADER field (#26) of
"PKG",141,22,1,"PAH",1,1,170,0)
    the PROTOCOL file (#101) to ensure users are limited to ListMan
"PKG",141,22,1,"PAH",1,1,171,0)
    actions based on their security key.
"PKG",141,22,1,"PAH",1,1,172,0)
 
"PKG",141,22,1,"PAH",1,1,173,0)
15. As part of this project, Kernel patch XU*8*580 introduced the 
"PKG",141,22,1,"PAH",1,1,174,0)
    following new fields to the NEW PERSON file (#200). Apart from the 
"PKG",141,22,1,"PAH",1,1,175,0)
    DEA#/VA# requirement, DEA further classifies what CS schedule a
"PKG",141,22,1,"PAH",1,1,176,0)
    provider is authorized to write. 
"PKG",141,22,1,"PAH",1,1,177,0)
 
"PKG",141,22,1,"PAH",1,1,178,0)
    55.1      SCHEDULE II NARCOTIC (S), [PS3;1]
"PKG",141,22,1,"PAH",1,1,179,0)
    55.2      SCHEDULE II NON-NARCOTIC (S), [PS3;2]
"PKG",141,22,1,"PAH",1,1,180,0)
    55.3      SCHEDULE III NARCOTIC (S), [PS3;3]
"PKG",141,22,1,"PAH",1,1,181,0)
    55.4      SCHEDULE III NON-NARCOTIC (S), [PS3;4]
"PKG",141,22,1,"PAH",1,1,182,0)
    55.5      SCHEDULE IV (S), [PS3;5]
"PKG",141,22,1,"PAH",1,1,183,0)
    55.6      SCHEDULE V (S), [PS3;6]
"PKG",141,22,1,"PAH",1,1,184,0)
 
"PKG",141,22,1,"PAH",1,1,185,0)
    If any one of the above fields are populated for a provider then when
"PKG",141,22,1,"PAH",1,1,186,0)
    placing a new order in backdoor pharmacy, the software will now check
"PKG",141,22,1,"PAH",1,1,187,0)
    for the drug schedule with the provider privileges. If the provider
"PKG",141,22,1,"PAH",1,1,188,0)
    does not have the credentials to write such orders then the software
"PKG",141,22,1,"PAH",1,1,189,0)
    will display a message (as shown below) and will not allow the 
"PKG",141,22,1,"PAH",1,1,190,0)
    selection that provider.
"PKG",141,22,1,"PAH",1,1,191,0)
    Example: When the provider does not have schedule 2 privileges, this
"PKG",141,22,1,"PAH",1,1,192,0)
    message is displayed: 
"PKG",141,22,1,"PAH",1,1,193,0)
    "Provider not authorized to write Federal Schedule 2 prescriptions."
"PKG",141,22,1,"PAH",1,1,194,0)
 
"PKG",141,22,1,"PAH",1,1,195,0)
16. When placing an order for a CS Detoxification drug, the software will 
"PKG",141,22,1,"PAH",1,1,196,0)
    now check for a valid Detoxification number for the provider. If the 
"PKG",141,22,1,"PAH",1,1,197,0)
    provider does not have a Detoxification number then the software will 
"PKG",141,22,1,"PAH",1,1,198,0)
    display a message "Provider must have a DETOX# to order this drug."
"PKG",141,22,1,"PAH",1,1,199,0)
 
"PKG",141,22,1,"PAH",1,1,200,0)
17. The Released and Unreleased Prescription Report [PSO RELEASE REPORT] 
"PKG",141,22,1,"PAH",1,1,201,0)
    is being modified to include CS as a selection to the input. The drug
"PKG",141,22,1,"PAH",1,1,202,0)
    name and CS schedule is being added to the output. Here are the
"PKG",141,22,1,"PAH",1,1,203,0)
    changes:                         
"PKG",141,22,1,"PAH",1,1,204,0)
 
"PKG",141,22,1,"PAH",1,1,205,0)
You are currently logged in under the CHEYENNE VAM&ROC division.
"PKG",141,22,1,"PAH",1,1,206,0)
Do you want to select a different division? NO// 
"PKG",141,22,1,"PAH",1,1,207,0)
 
"PKG",141,22,1,"PAH",1,1,208,0)
Do you want ONLY Unreleased Prescriptions? NO// 
"PKG",141,22,1,"PAH",1,1,209,0)
Include (C)S Rx only, (N)on CS Rx only, or (B)oth (C/N/B): B// Controlled 
"PKG",141,22,1,"PAH",1,1,210,0)
Substances Rxs Only
"PKG",141,22,1,"PAH",1,1,211,0)
 
"PKG",141,22,1,"PAH",1,1,212,0)
Select controlled substance schedules
"PKG",141,22,1,"PAH",1,1,213,0)
 
"PKG",141,22,1,"PAH",1,1,214,0)
     Select one of the following:
"PKG",141,22,1,"PAH",1,1,215,0)
 
"PKG",141,22,1,"PAH",1,1,216,0)
          1         SCHEDULES I - II
"PKG",141,22,1,"PAH",1,1,217,0)
          2         SCHEDULES III - V
"PKG",141,22,1,"PAH",1,1,218,0)
          3         SCHEDULES I - V
"PKG",141,22,1,"PAH",1,1,219,0)
 
"PKG",141,22,1,"PAH",1,1,220,0)
Select Schedule(s): 3// 
"PKG",141,22,1,"PAH",1,1,221,0)
 
"PKG",141,22,1,"PAH",1,1,222,0)
The report currently shows the count of unreleased and copay
"PKG",141,22,1,"PAH",1,1,223,0)
prescriptions, but not the count of released prescriptions. The report is
"PKG",141,22,1,"PAH",1,1,224,0)
modified with this patch to include the count of released prescriptions.
"PKG",141,22,1,"PAH",1,1,225,0)
 
"PKG",141,22,1,"PAH",1,1,226,0)
18. The following options are being modified to include the
"PKG",141,22,1,"PAH",1,1,227,0)
    DETOX/MAINTENANCE ID NUMBER field (#53.11) and the DEA EXPIRATION DATE
"PKG",141,22,1,"PAH",1,1,228,0)
    field (#747.44) of the NEW PERSON file (#200) as part of the screen. 
"PKG",141,22,1,"PAH",1,1,229,0)
    The DEA EXPIRATION DATE field will be prompted only if the PROVIDER
"PKG",141,22,1,"PAH",1,1,230,0)
    TYPE field (#53.6) of the NEW PERSON file (#200) is marked as "FEE 
"PKG",141,22,1,"PAH",1,1,231,0)
    BASIS".
"PKG",141,22,1,"PAH",1,1,232,0)
 
"PKG",141,22,1,"PAH",1,1,233,0)
    Add New Providers [PSO PROVIDER ADD]
"PKG",141,22,1,"PAH",1,1,234,0)
    Edit Provider [PSO PROVIDER EDIT]
"PKG",141,22,1,"PAH",1,1,235,0)
    View Provider [PSO PROVIDER INQUIRE]
"PKG",141,22,1,"PAH",1,1,236,0)
 
"PKG",141,22,1,"PAH",1,1,237,0)
19. Currently, the default days supply for all drugs is set from the DAYS 
"PKG",141,22,1,"PAH",1,1,238,0)
    SUPPLY field (#3) of the RX PATIENT STATUS file (#53) up to a maximum
"PKG",141,22,1,"PAH",1,1,239,0)
    of 90. With this project, the default for CS schedule II-V drugs will
"PKG",141,22,1,"PAH",1,1,240,0)
    be set to 30 or from the DAYS SUPPLY field (#3) of the RX PATIENT
"PKG",141,22,1,"PAH",1,1,241,0)
    STATUS file (#53) if it is less than 30. Also, the Integration Control
"PKG",141,22,1,"PAH",1,1,242,0)
    Registration #3278 that returns days supply (DSUP^PSOSIGDS) to CPRS is
"PKG",141,22,1,"PAH",1,1,243,0)
    modified to return 30 or from the DAYS SUPPLY field (#3) of the RX
"PKG",141,22,1,"PAH",1,1,244,0)
    PATIENT STATUS file (#53) if it is less than 30 for CS schedule II-V
"PKG",141,22,1,"PAH",1,1,245,0)
    drugs.
"PKG",141,22,1,"PAH",1,1,246,0)
 
"PKG",141,22,1,"PAH",1,1,247,0)
20. The pharmacy release slip portion of the Laser Label is being 
"PKG",141,22,1,"PAH",1,1,248,0)
    modified to include the text "(DSIG)" or "(NOT DSIG)" after the
"PKG",141,22,1,"PAH",1,1,249,0)
    patient's name to indicate that the prescription is digitally signed
"PKG",141,22,1,"PAH",1,1,250,0)
    or not digitally signed.
"PKG",141,22,1,"PAH",1,1,251,0)
 
"PKG",141,22,1,"PAH",1,1,252,0)
21. This patch addresses the issue reported in REMEDY ticket #595795, to
"PKG",141,22,1,"PAH",1,1,253,0)
    ensure that when editing an orderable item/dispensed drug, the 
"PKG",141,22,1,"PAH",1,1,254,0)
    instruction field is displayed only when editing the pending order 
"PKG",141,22,1,"PAH",1,1,255,0)
    and not when editing an active or non-verified order.
"PKG",141,22,1,"PAH",1,1,256,0)
 
"PKG",141,22,1,"PAH",1,1,257,0)
22. The Expire Prescriptions [PSO EXPIRE PRESCRIPTIONS] option that 
"PKG",141,22,1,"PAH",1,1,258,0)
    currently runs as a nightly job is being modified to check for the
"PKG",141,22,1,"PAH",1,1,259,0)
    Institutional DEA 'expiration date'. If the expiration date is within
"PKG",141,22,1,"PAH",1,1,260,0)
    30 calendar days or past expiration then a mail message will be
"PKG",141,22,1,"PAH",1,1,261,0)
    generated and sent to PSDMGR key holders. Here is an example when the
"PKG",141,22,1,"PAH",1,1,262,0)
    expiration date is within 30 days:
"PKG",141,22,1,"PAH",1,1,263,0)
 
"PKG",141,22,1,"PAH",1,1,264,0)
Subj: 500:Institutional DEA Expiration Date is about to expire  [#140331]
"PKG",141,22,1,"PAH",1,1,265,0)
03/20/12@11:57  3 lines
"PKG",141,22,1,"PAH",1,1,266,0)
From: POSTMASTER  In 'IN' basket.   Page 1  *New*
"PKG",141,22,1,"PAH",1,1,267,0)
-----------------------------------------------------------------------
"PKG",141,22,1,"PAH",1,1,268,0)
 
"PKG",141,22,1,"PAH",1,1,269,0)
Please update Institutional DEA Certification Date. Will expire on 
"PKG",141,22,1,"PAH",1,1,270,0)
3/24/12.
"PKG",141,22,1,"PAH",1,1,271,0)
 
"PKG",141,22,1,"PAH",1,1,272,0)
******************************
"PKG",141,22,1,"PAH",1,1,273,0)
 
"PKG",141,22,1,"PAH",1,1,274,0)
Here is an example when the DEA Expiration Date is past expiration date:
"PKG",141,22,1,"PAH",1,1,275,0)
 
"PKG",141,22,1,"PAH",1,1,276,0)
 
"PKG",141,22,1,"PAH",1,1,277,0)
Subj: 500:Institutional DEA Expiration Date has expired  [#140333]
"PKG",141,22,1,"PAH",1,1,278,0)
03/20/12@12:08  3 lines
"PKG",141,22,1,"PAH",1,1,279,0)
From: POSTMASTER  In 'IN' basket.   Page 1  *New*
"PKG",141,22,1,"PAH",1,1,280,0)
----------------------------------------------------------------------
"PKG",141,22,1,"PAH",1,1,281,0)
 
"PKG",141,22,1,"PAH",1,1,282,0)
Please update Institutional DEA Certification Date. Expired on 2/19/12.
"PKG",141,22,1,"PAH",1,1,283,0)
 
"PKG",141,22,1,"PAH",1,1,284,0)
**********************************
"QUES","XPF1",0)
Y
"QUES","XPF1","??")
^D REP^XPDH
"QUES","XPF1","A")
Shall I write over your |FLAG| File
"QUES","XPF1","B")
YES
"QUES","XPF1","M")
D XPF1^XPDIQ
"QUES","XPF2",0)
Y
"QUES","XPF2","??")
^D DTA^XPDH
"QUES","XPF2","A")
Want my data |FLAG| yours
"QUES","XPF2","B")
YES
"QUES","XPF2","M")
D XPF2^XPDIQ
"QUES","XPI1",0)
YO
"QUES","XPI1","??")
^D INHIBIT^XPDH
"QUES","XPI1","A")
Want KIDS to INHIBIT LOGONs during the install
"QUES","XPI1","B")
NO
"QUES","XPI1","M")
D XPI1^XPDIQ
"QUES","XPM1",0)
PO^VA(200,:EM
"QUES","XPM1","??")
^D MG^XPDH
"QUES","XPM1","A")
Enter the Coordinator for Mail Group '|FLAG|'
"QUES","XPM1","B")

"QUES","XPM1","M")
D XPM1^XPDIQ
"QUES","XPO1",0)
Y
"QUES","XPO1","??")
^D MENU^XPDH
"QUES","XPO1","A")
Want KIDS to Rebuild Menu Trees Upon Completion of Install
"QUES","XPO1","B")
NO
"QUES","XPO1","M")
D XPO1^XPDIQ
"QUES","XPZ1",0)
Y
"QUES","XPZ1","??")
^D OPT^XPDH
"QUES","XPZ1","A")
Want to DISABLE Scheduled Options, Menu Options, and Protocols
"QUES","XPZ1","B")
NO
"QUES","XPZ1","M")
D XPZ1^XPDIQ
"QUES","XPZ2",0)
Y
"QUES","XPZ2","??")
^D RTN^XPDH
"QUES","XPZ2","A")
Want to MOVE routines to other CPUs
"QUES","XPZ2","B")
NO
"QUES","XPZ2","M")
D XPZ2^XPDIQ
"RTN")
33
"RTN","PSOCAN4")
0^27^B49357876^B47636509
"RTN","PSOCAN4",1,0)
PSOCAN4 ;BIR/SAB - rx speed dc listman ;10/23/06 11:50am
"RTN","PSOCAN4",2,0)
 ;;7.0;OUTPATIENT PHARMACY;**20,24,27,63,88,117,131,259,268,225,358,385,391**;DEC 1997;Build 13
"RTN","PSOCAN4",3,0)
 ;External reference to File #200 supported by DBIA 224
"RTN","PSOCAN4",4,0)
 ;External reference NA^ORX1 supported by DBIA 2186
"RTN","PSOCAN4",5,0)
 ;External references to L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
"RTN","PSOCAN4",6,0)
 ;External reference to PSDRUG supported by DBIA 221
"RTN","PSOCAN4",7,0)
 ;External reference to PS(50.7 supported by DBIA 2223
"RTN","PSOCAN4",8,0)
 ;External reference to PS(50.606 supported by DBIA 2174
"RTN","PSOCAN4",9,0)
 ;External reference to ELIG^VADPT supported by DBIA 10061
"RTN","PSOCAN4",10,0)
SEL I '$D(^XUSEC("PSORPH",DUZ)) S VALMSG="Unauthorized Action Selection.",VALMBCK="" Q
"RTN","PSOCAN4",11,0)
 N VALMCNT I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q
"RTN","PSOCAN4",12,0)
 S DFNHLD=PSODFN
"RTN","PSOCAN4",13,0)
 S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK S VALMBCK="" Q
"RTN","PSOCAN4",14,0)
 K PSOPLCK S RXCNT=0 K PSOFDR,DIR,DUOUT,DIRUT S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR S LST=Y I $D(DTOUT)!($D(DUOUT)) K DIR,DIRUT,DTOUT,DUOUT S VALMBCK="" D ULP Q
"RTN","PSOCAN4",15,0)
 K DIR,DIRUT,DTOUT,PSOOELSE,DTOUT I +LST S (SPEED,PSOOELSE)=1 D  D KCAN^PSOCAN3
"RTN","PSOCAN4",16,0)
 .S PSOCANRA=1 D RQTEST
"RTN","PSOCAN4",17,0)
 .; The PSOTRIC variable is needed by NOOR, which is called by COM^PSOCAN1, to determine the default Nature of Order.
"RTN","PSOCAN4",18,0)
 .N PSOTRIC S PSOTRIC=$$ELIG(PSODFN)
"RTN","PSOCAN4",19,0)
 .D FULL^VALM1,COM^PSOCAN1 I '$D(INCOM)!($D(DIRUT)) K SPEED S VALMBCK="R" Q
"RTN","PSOCAN4",20,0)
 .D FULL^VALM1 F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']""  S ORN=$P(LST,",",ORD) D @$S(+PSOLST(ORN)=52:"RX",1:"PEN")
"RTN","PSOCAN4",21,0)
 .S VALMBCK="R"
"RTN","PSOCAN4",22,0)
 I '$G(PSOOELSE) S VALMBCK=""
"RTN","PSOCAN4",23,0)
 D ^PSOBUILD,BLD^PSOORUT1,RV^PSOORFL K PSOMSG,RXCNT,DIR,DIRUT,DTOUT,DUOUT,LST,ORD,IEN,ORN,RPH,ST,REFL,REF,PSOACT,ORSV,PSORNW,PSORENW,PSONO,PSOCO,PSOCU,PSODIR,DSMSG,SAVORD,SAVORN,SPEED,DIRUT,PSONOOR
"RTN","PSOCAN4",24,0)
 D INVALD^PSOCAN1 K PSINV,PSOOELSE,INCOM,COM S PSODFN=DFNHLD K DFNHLD D ULP
"RTN","PSOCAN4",25,0)
 Q
"RTN","PSOCAN4",26,0)
ULP D UL^PSSLOCK(+$G(PSODFN)) Q
"RTN","PSOCAN4",27,0)
 ;
"RTN","PSOCAN4",28,0)
RX Q:'$D(^XUSEC("PSORPH",DUZ))
"RTN","PSOCAN4",29,0)
 D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) D  D PAUSE^VALM1 K PSOMSG Q
"RTN","PSOCAN4",30,0)
 .I $P($G(PSOMSG),"^",2)'="" W $C(7),!!,$P($G(PSOMSG),"^",2),!,"Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^"),! Q
"RTN","PSOCAN4",31,0)
 .W $C(7),!!,"Another person is editing Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^"),!
"RTN","PSOCAN4",32,0)
 I $P($G(^PSRX($P(PSOLST(ORN),"^",2),"PKI")),"^")=1,'$D(^XUSEC("PSDRPH",DUZ)) W $C(7),!!,"Digitally Signed Order - PSDRPH key required" D PAUSE^VALM1 Q
"RTN","PSOCAN4",33,0)
 S RXSP=1 K PSCAN S (EN,X)=$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^") S Y=$P(PSOLST(ORN),"^",2)_"^"_X,Y(0,0)=X,Y(0)=$G(^PSRX($P(PSOLST(ORN),"^",2),0)) D
"RTN","PSOCAN4",34,0)
 .I $P(^PSRX(+Y,"STA"),"^")=1!($P(^("STA"),"^")=4) D  Q
"RTN","PSOCAN4",35,0)
 ..S:$G(PSONOOR)'="" PSONOORA=$G(PSONOOR) D DEL S:$G(PSONOORA)'="" PSONOOR=$G(PSONOORA) K PSONOORA Q
"RTN","PSOCAN4",36,0)
 .S YY=Y,YY(0,0)=Y(0,0),(PSODFN,DFN)=$P(Y(0),"^",2) D:$G(DFN) CHK^PSOCAN I DEAD!($P(^PSRX(+YY,"STA"),"^")>11),$P(^("STA"),"^")<16 S PSINV(EN)="" Q
"RTN","PSOCAN4",37,0)
 .S DA=+YY I $P($G(^PSRX(DA,"STA")),"^")=11!($P($G(^(2)),"^",6)<DT) D EXP^PSOCAN
"RTN","PSOCAN4",38,0)
 .S RX=YY(0,0) D:$D(^PSRX(DA,0)) SPEED1^PSOCAN1
"RTN","PSOCAN4",39,0)
 K YY I '$D(PSCAN) D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) Q
"RTN","PSOCAN4",40,0)
 S RX="",RXCNT=0 F  S RX=$O(PSCAN(RX)) Q:RX=""  S DA=+PSCAN(RX),REA=$P(PSCAN(RX),"^",2),RXCNT=RXCNT+1 D SHOW^PSOCAN1
"RTN","PSOCAN4",41,0)
 S RX="" F  S RX=$O(PSCAN(RX)) Q:RX=""  D ACT
"RTN","PSOCAN4",42,0)
 D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2))
"RTN","PSOCAN4",43,0)
 Q
"RTN","PSOCAN4",44,0)
ACT S DA=+PSCAN(RX),REA=$P(PSCAN(RX),"^",2),II=RX,PSODFN=$P(^PSRX(DA,0),"^",2) I REA="R" D REINS^PSOCAN2 Q
"RTN","PSOCAN4",45,0)
 D CAN1^PSOCAN3 Q
"RTN","PSOCAN4",46,0)
PEN ;discontinue pending orders
"RTN","PSOCAN4",47,0)
 S SAVORD=ORD,SAVORN=ORN
"RTN","PSOCAN4",48,0)
 S ORD=$P(PSOLST(ORN),"^",2) D PSOL^PSSLOCK(+ORD_"S") I '$G(PSOMSG) D  D MEDDIS K PSOMSG G OK
"RTN","PSOCAN4",49,0)
 .I $P($G(PSOMSG),"^",2)'="" W $C(7),!!,$P($G(PSOMSG),"^",2)_"  (Pending order)",! Q
"RTN","PSOCAN4",50,0)
 .W $C(7),!!,"Another person is editing this Pending order.",!
"RTN","PSOCAN4",51,0)
 I $P(^PS(52.41,ORD,0),"^",24),'$D(^XUSEC("PSDRPH",DUZ)) W $C(7),!!,"Digitally Signed Order - PSDRPH key required" D PAUSE^VALM1 G OK
"RTN","PSOCAN4",52,0)
 I $P(^PS(52.41,ORD,0),"^",3)="RF" S DA=ORD,DIK="^PS(52.41," D ^DIK K DA,DIK D PSOUL^PSSLOCK(ORD_"S") Q
"RTN","PSOCAN4",53,0)
 K ^PS(52.41,"AOR",$P(^PS(52.41,ORD,0),"^",2),+$P($G(^PS(52.41,ORD,"INI")),"^"),ORD) S $P(^PS(52.41,ORD,0),"^",3)="DC"
"RTN","PSOCAN4",54,0)
 D EN^PSOHLSN(+^PS(52.41,ORD,0),"OC",INCOM,PSONOOR)
"RTN","PSOCAN4",55,0)
 D PSOUL^PSSLOCK(ORD_"S")
"RTN","PSOCAN4",56,0)
OK S ORD=SAVORD,ORN=SAVORN Q
"RTN","PSOCAN4",57,0)
NOOR ;ask nature of order
"RTN","PSOCAN4",58,0)
 N RX
"RTN","PSOCAN4",59,0)
 I '$D(PSOTRIC),$G(ORN) S RX=+$P($G(PSOLST(ORN)),U,2) I RX N PSOTRIC S PSOTRIC=$$TRIC^PSOREJP1(RX)
"RTN","PSOCAN4",60,0)
 D FULL^VALM1
"RTN","PSOCAN4",61,0)
 K DIR,DTOUT,DTOUT,DIRUT I $T(NA^ORX1)]"" D  Q:$D(DIRUT)  G NOORXP
"RTN","PSOCAN4",62,0)
 .S PSONOOR=$$NA^ORX1($S($G(PSOTRIC):"R",1:"S"),0,"B","Nature of Order",0,"WPSDIVR"_$S(+$G(^VA(200,DUZ,"PS")):"E",1:""))
"RTN","PSOCAN4",63,0)
 .I +PSONOOR S PSONOOR=$P(PSONOOR,"^",3) Q
"RTN","PSOCAN4",64,0)
 .S DIRUT=1 K PSONOOR
"RTN","PSOCAN4",65,0)
 ;cnf, PSO*7*358, default to "SERVICE REJECTED" if TRICARE or CHAMPVA
"RTN","PSOCAN4",66,0)
 S DIR("A")="Nature of Order: ",DIR("B")=$S($G(PSOTRIC):"SERVICE REJECTED",$G(DODR):"SERVICE CORRECTED",1:"WRITTEN")
"RTN","PSOCAN4",67,0)
 S DIR(0)="SA^W:WRITTEN;V:VERBAL;P:TELEPHONE;S:SERVICE CORRECTED;D:DUPLICATE;I:POLICY;R:SERVICE REJECTED"_$S(+$G(^VA(200,DUZ,"PS")):";E:PROVIDER ENTERED",1:"")
"RTN","PSOCAN4",68,0)
 D ^DIR K DIR,DTOUT,DTOUT Q:$D(DIRUT)  S PSONOOR=Y
"RTN","PSOCAN4",69,0)
NOORXP I $G(PSOCANRA),'$G(PSOCANRZ) D REQ
"RTN","PSOCAN4",70,0)
NOORX S:$D(DIRUT)&($G(SPEED)) VALMBCK="Q"
"RTN","PSOCAN4",71,0)
 Q
"RTN","PSOCAN4",72,0)
DEL ;deletes non-verified Rxs
"RTN","PSOCAN4",73,0)
 D FULL^VALM1
"RTN","PSOCAN4",74,0)
 W ! K DIR,DIRUT,DUOUT S DIR(0)="Y",DIR("B")="No",DIR("A",1)="Rx # "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^")_" is in a Non-Verified Status.",DIR("A")="Are sure you want to mark the Rx as deleted" D ^DIR I 'Y!($D(DIRUT)) S VALMBCK="R" G EX
"RTN","PSOCAN4",75,0)
 I '$G(SPEED) D  I $D(DIRUT) G EX
"RTN","PSOCAN4",76,0)
 .D NOOR I $D(DIRUT) S VALMSG="No Action Taken!",VALMBCK="R" Q
"RTN","PSOCAN4",77,0)
 .K DIR S DIR("A")="Comments",DIR("B")="Per Pharmacy Request",DIR(0)="F^5:100" D ^DIR K DIR I $D(DIRUT) S VALMSG="No Action Taken!" Q
"RTN","PSOCAN4",78,0)
 K PSDEL,PSORX("INTERVENE") S PSOZVER=1,DA=$P(PSOLST(ORN),"^",2)
"RTN","PSOCAN4",79,0)
 D ENQ^PSORXDL
"RTN","PSOCAN4",80,0)
EX Q
"RTN","PSOCAN4",81,0)
REQ ;prompt for requesting provider
"RTN","PSOCAN4",82,0)
 I '$G(PSOCANRD),$G(PSOCANRP),$G(ORD),$D(^PS(52.41,ORD,0)) S PSOCANRD=+$P($G(^PS(52.41,ORD,0)),"^",5)
"RTN","PSOCAN4",83,0)
 I $G(PSOCANRD) D
"RTN","PSOCAN4",84,0)
 .I $D(^VA(200,PSOCANRD,"PS")),$P($G(^("PS")),"^"),$S('$P(^("PS"),"^",4):1,1:$P(^("PS"),"^",4)'<DT) Q
"RTN","PSOCAN4",85,0)
 .K PSOCANRD
"RTN","PSOCAN4",86,0)
 W ! K DIC S DIC=200,DIC(0)="AEQMZ",DIC("A")="Requesting PROVIDER: ",DIC("S")="I $D(^(""PS"")),$P(^(""PS""),""^""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)'<DT)" I $G(PSOCANRD) S DIC("B")=PSOCANRD
"RTN","PSOCAN4",87,0)
 D ^DIC K DIC S:$G(Y)<0!($D(DTOUT))!($D(DUOUT)) DIRUT=1 I $G(Y) S PSOCANRC=+$G(Y),PSOCANRN=$P($G(Y),"^",2),PSOCANRZ=1
"RTN","PSOCAN4",88,0)
 Q
"RTN","PSOCAN4",89,0)
RQTEST ;
"RTN","PSOCAN4",90,0)
 N PMIN,PMINZ,PMINFLAG
"RTN","PSOCAN4",91,0)
 S PMINFLAG=0 F PMIN=1:1:$L(LST,",") Q:$P(LST,",",PMIN)']""  S PMINZ=$P(LST,",",PMIN) D
"RTN","PSOCAN4",92,0)
 .I $P($G(PSOLST(PMINZ)),"^")=52 I $P($G(^PSRX(+$P($G(PSOLST(PMINZ)),"^",2),"STA")),"^")'=12,'$G(PMINFLAG) S PSOCANRD=+$P($G(^PSRX(+$P($G(PSOLST(PMINZ)),"^",2),0)),"^",4) S PMINFLAG=1
"RTN","PSOCAN4",93,0)
 .I $P($G(PSOLST(PMINZ)),"^")=52.41,'$G(PMINFLAG) S PSOCANRD=$P($G(^PS(52.41,+$P($G(PSOLST(PMINZ)),"^",2),0)),"^",5) S PMINFLAG=1
"RTN","PSOCAN4",94,0)
 I '$G(PMINFLAG) S PSOCANRZ=1
"RTN","PSOCAN4",95,0)
 Q
"RTN","PSOCAN4",96,0)
MEDDIS ;
"RTN","PSOCAN4",97,0)
 N PSOFMMD
"RTN","PSOCAN4",98,0)
 Q:'$G(ORD)
"RTN","PSOCAN4",99,0)
 Q:'$D(^PS(52.41,ORD,0))
"RTN","PSOCAN4",100,0)
 I $P(^PS(52.41,ORD,0),"^",9) W "Drug: "_$P($G(^PSDRUG(+$P(^PS(52.41,ORD,0),"^",9),0)),"^") D PAUSE^VALM1 Q
"RTN","PSOCAN4",101,0)
 I $P(^PS(52.41,ORD,0),"^",8) S PSOFMMD=$P(^(0),"^",8) W "Orderable Item: "_$P($G(^PS(50.7,PSOFMMD,0)),"^")_"  "_$P($G(^PS(50.606,+$P($G(^PS(50.7,PSOFMMD,0)),"^",2),0)),"^") D PAUSE^VALM1
"RTN","PSOCAN4",102,0)
 Q
"RTN","PSOCAN4",103,0)
 ;
"RTN","PSOCAN4",104,0)
REF ;CONT. FROM REF^PSOCAN2; PSO*7*259
"RTN","PSOCAN4",105,0)
 N PSOSIEN S PSOSIEN=0
"RTN","PSOCAN4",106,0)
 F  S PSOSIEN=$O(^PS(52.5,"B",DA,PSOSIEN)) Q:'PSOSIEN  D  Q:PSONODEL
"RTN","PSOCAN4",107,0)
 .I $P($G(^PS(52.5,PSOSIEN,0)),"^",13)'=IFN Q  ;NOT SAME REFILL
"RTN","PSOCAN4",108,0)
 .I '$P($G(^PS(52.5,PSOSIEN,"P")),"^") Q  ;SUSPENSE LABEL PRINT
"RTN","PSOCAN4",109,0)
 .S PSONODEL=1   ;REFILL NODE SHOULD NOT BE DELETED
"RTN","PSOCAN4",110,0)
 Q
"RTN","PSOCAN4",111,0)
 ;
"RTN","PSOCAN4",112,0)
ELIG(DFN) ; Return primary eligibility
"RTN","PSOCAN4",113,0)
 ; Input:
"RTN","PSOCAN4",114,0)
 ;   DFN: Patient IEN (required)
"RTN","PSOCAN4",115,0)
 ; Output:
"RTN","PSOCAN4",116,0)
 ;   "": No DFN passed in, 0: Veteran, 1: TRICARE, 2: CHAMPVA
"RTN","PSOCAN4",117,0)
 I '$G(DFN) Q ""
"RTN","PSOCAN4",118,0)
 ; Variables VAEL, VAERR, and I are modified by ELIG^VADPT
"RTN","PSOCAN4",119,0)
 N VAEL,VAERR,I,ELIG
"RTN","PSOCAN4",120,0)
 ; ELIG^VADPT assumes DFN is defined and returns arrays VAEL and VAERR
"RTN","PSOCAN4",121,0)
 D ELIG^VADPT ; Supported by IA 10061
"RTN","PSOCAN4",122,0)
 ; VAEL(1) contains the primary eligibility
"RTN","PSOCAN4",123,0)
 S ELIG=$P($G(VAEL(1)),U,2)
"RTN","PSOCAN4",124,0)
 Q $S(ELIG="TRICARE"!(ELIG="SHARING AGREEMENT"):1,ELIG="CHAMPVA":2,1:0)
"RTN","PSODGDGP")
0^29^B66741905^B57788736
"RTN","PSODGDGP",1,0)
PSODGDGP ;BIR/SAB - drug drug interaction checker ;4/14/93
"RTN","PSODGDGP",2,0)
 ;;7.0;OUTPATIENT PHARMACY;**251,387,379,391**;DEC 1997;Build 13
"RTN","PSODGDGP",3,0)
 ;External reference to ^PSDRUG supported by DBIA 221
"RTN","PSODGDGP",4,0)
 ;External references PSOUL^PSSLOCK supported by DBIA 2789
"RTN","PSODGDGP",5,0)
 ;External references to ^ORRDI1 supported by DBIA 4659
"RTN","PSODGDGP",6,0)
 ;External reference ^XTMP("ORRDI" supported by DBIA 4660
"RTN","PSODGDGP",7,0)
 ;External reference to $$DS^PSSDSAPI supported by DBIA 5425
"RTN","PSODGDGP",8,0)
 N DRG,PSOREMOT S (CRIT,DRG,LSI,DGI,DGS,SER,SERS,STA,PSOICT)="",PSOREMOT=0
"RTN","PSODGDGP",9,0)
 D BLD Q:+$G(PSORX("DFLG"))!($G(PSODLQT))
"RTN","PSODGDGP",10,0)
 I '$D(^XUSEC("PSORPH",DUZ)),$G(DGI)]"" S:$G(CRIT) PSONEW("STATUS")=4 W $C(7),!,"DRUG INTERACTON WITH RX #s: "_LSI,!
"RTN","PSODGDGP",11,0)
 I '$D(^XUSEC("PSORPH",DUZ)),(","_$G(^TMP("PSOSER",$J,0))_",")[(",1,") S:$D(^TMP("PSODGI",$J,0)) PSONEW("STATUS")=4
"RTN","PSODGDGP",12,0)
 K DRG,NDF,PSOICT,IT,LSI
"RTN","PSODGDGP",13,0)
 I +$G(PSORX("DFLG")) Q
"RTN","PSODGDGP",14,0)
 I +$G(PSODRUG("NDF"))'=0 D
"RTN","PSODGDGP",15,0)
 .I $T(HAVEHDR^ORRDI1)']"" Q
"RTN","PSODGDGP",16,0)
 .I '$$HAVEHDR^ORRDI1 Q
"RTN","PSODGDGP",17,0)
 .D HD^PSODDPR2():(($Y+5)>IOSL)
"RTN","PSODGDGP",18,0)
 .I $P($G(^XTMP("ORRDI","PSOO",PSODFN,0)),"^",3)<0 W !!,"Remote data not available - Only local order checks processed.",!! S PSOREMOT=1 D HD^PSODDPR2():(($Y+5)>IOSL) Q
"RTN","PSODGDGP",19,0)
 .I $D(^TMP($J,"DI"_PSODFN)) K ^TMP($J,"DI") M ^TMP($J,"DI")=^TMP($J,"DI"_PSODFN) D DRGINT^PSOORRD2
"RTN","PSODGDGP",20,0)
 .K ^TMP($J,"DI"_PSODFN),^TMP($J,"DI")
"RTN","PSODGDGP",21,0)
 I '$D(^XUSEC("PSORPH",DUZ)),$G(PSOREMOT)!($G(DGI)]"") K DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to Continue..." D ^DIR K DIR,DUOUT,DTOUT
"RTN","PSODGDGP",22,0)
 Q
"RTN","PSODGDGP",23,0)
TECH ;add tech entry to RX VERIFY file (#52.4); called from new order/copy/renew
"RTN","PSODGDGP",24,0)
 I $$DS^PSSDSAPI,+$G(^TMP("PSODOSF",$J,0)) S ^PS(52.4,PSOXIRXN,1)=^TMP("PSODOSF",$J,0)
"RTN","PSODGDGP",25,0)
 Q:'$D(^TMP("PSODGI",$J,0))
"RTN","PSODGDGP",26,0)
 S $P(^PSRX(PSOXIRXN,"DRI"),"^")=^TMP("PSOSER",$J,0)_"^"_^TMP("PSODGI",$J,0)
"RTN","PSODGDGP",27,0)
 S $P(^PS(52.4,PSOXIRXN,0),"^",8)=1,$P(^PS(52.4,PSOXIRXN,0),"^",9)=^TMP("PSOSER",$J,0),$P(^PS(52.4,PSOXIRXN,0),"^",10)=^TMP("PSODGI",$J,0)
"RTN","PSODGDGP",28,0)
 Q
"RTN","PSODGDGP",29,0)
TECH2(PSOXIRXN,PSODFN,DUZ,PSOX) ;
"RTN","PSODGDGP",30,0)
 I $D(PSOX("NOPSDRPH")) G T3
"RTN","PSODGDGP",31,0)
 Q:$D(^XUSEC("PSORPH",DUZ))
"RTN","PSODGDGP",32,0)
T3           ;
"RTN","PSODGDGP",33,0)
 ; The only time PSOX("NOPSDRPH) key is defined equal to 1 is for controlled substances and the user doesn't hold
"RTN","PSODGDGP",34,0)
 ; the PSDRPH key.
"RTN","PSODGDGP",35,0)
 N PSODWARN,PSOSIGNIF,PSOINTSV,PSOTLBL S (PSODWARN,PSOSIGNIF,PSOTLBL,PSOINTSV)=0
"RTN","PSODGDGP",36,0)
 S:$$DS^PSSDSAPI&(+$G(^TMP("PSODOSF",$J,0))) PSODWARN=1 ;dosing drug warning
"RTN","PSODGDGP",37,0)
 I $D(^TMP("PSOSER",$J,0)) S PSOINTSV=$G(^TMP("PSOSER",$J,0)) S:PSOINTSV[1 PSODWARN=1 S:PSOINTSV[2 PSOSIGNIF=1 ;critical and significant drug interaction drug warnings
"RTN","PSODGDGP",38,0)
 ;
"RTN","PSODGDGP",39,0)
 ; When verification is OFF and there's a significant drug interaction or the user doesn't hold the PSDRPH key,
"RTN","PSODGDGP",40,0)
 ; set file 52 "DRI" node for the signficant drug interactions but don't quit. When the verification switch is off, the bottle label and the tech warning 
"RTN","PSODGDGP",41,0)
 ; a tech warning label and the bottle label must print when signficant interactions are present. However if the
"RTN","PSODGDGP",42,0)
 ; the PSOX("NOPSDRPH") variable is defined, no labels are allowed to print and processing should continue.
"RTN","PSODGDGP",43,0)
 ;
"RTN","PSODGDGP",44,0)
 I '$G(PSORX("VERIFY")),'PSODWARN&($G(PSOSIGNIF)) D  Q:'$D(PSOX("NOPSDRPH")) PSOTLBL  ;don't set 52.4 when verification is off and only signficiant interation
"RTN","PSODGDGP",45,0)
 .S $P(^PSRX(PSOXIRXN,"DRI"),"^")=^TMP("PSOSER",$J,0)
"RTN","PSODGDGP",46,0)
 .S $P(^PSRX(PSOXIRXN,"DRI"),"^",2)=^TMP("PSODGI",$J,0)
"RTN","PSODGDGP",47,0)
 .I '$P(PSOPAR,"^",2) S PSOTLBL=1
"RTN","PSODGDGP",48,0)
 ;
"RTN","PSODGDGP",49,0)
 ; If verification is ON, set file 52.4. If there are critical drug interactions or dose warnings, the fields to 
"RTN","PSODGDGP",50,0)
 ; indicate these must be set and a tech warning label should print. If the PSOX("NOPSDRPH") variable is present,
"RTN","PSODGDGP",51,0)
 ; file 52.4 should be set (along with any drug interaction and dose warning data) and the technician warning label
"RTN","PSODGDGP",52,0)
 ; should print (PSOTLBL=2)
"RTN","PSODGDGP",53,0)
 ;
"RTN","PSODGDGP",54,0)
 I ($D(PSOX("NOPSDRPH")))!($G(PSODWARN))!($G(PSORX("VERIFY"))) D
"RTN","PSODGDGP",55,0)
 .K DIC,DLAYGO,DINUM,DIADD,X,DD,DO S DIC="^PS(52.4,",DLAYGO=52.4,DINUM=PSOXIRXN,DIC(0)="ML",X=PSOXIRXN
"RTN","PSODGDGP",56,0)
 .D FILE^DICN K DD,DO,DIC,DLAYGO,DINUM S ^PS(52.4,PSOXIRXN,0)=PSOXIRXN_"^"_PSODFN_"^"_DUZ_"^"_"^"_$E(PSOX("LOGIN DATE"),1,7)_"^"_PSOXIRXN_"^"_PSOX("STOP DATE")
"RTN","PSODGDGP",57,0)
 .I '$D(PSOX("NOPSDRPH")) Q:PSOINTSV'[1&('PSODWARN)
"RTN","PSODGDGP",58,0)
 .D TECH
"RTN","PSODGDGP",59,0)
 ;
"RTN","PSODGDGP",60,0)
 I $D(^PS(52.4,PSOXIRXN)) K DIK,DA S DIK="^PS(52.4,",DA=PSOX("IRXN") D IX^DIK K DIK,DA
"RTN","PSODGDGP",61,0)
 I '$G(PSORX("VERIFY")) S:(PSOX("STATUS")=4!$G(PSODWARN)) PSOTLBL=1 ;verification off, dose warn or drug interaction, print technician warning label
"RTN","PSODGDGP",62,0)
 I $G(PSORX("VERIFY")) S PSOTLBL=$S('$G(PSODWARN)&('$G(PSOSIGNIF)):2,'$G(PSODWARN)&($G(PSOSIGNIF)):2,$G(PSODWARN):1,1:0)
"RTN","PSODGDGP",63,0)
 ;
"RTN","PSODGDGP",64,0)
 ; If the PSOX("NOPSDRPH") variable is present and regardless of the verification switch, labels cannot be 
"RTN","PSODGDGP",65,0)
 ; printed (i.e. PSOTLBL=2)
"RTN","PSODGDGP",66,0)
 I ($D(PSOX("NOPSDRPH"))) S PSOTLBL=2
"RTN","PSODGDGP",67,0)
 Q PSOTLBL
"RTN","PSODGDGP",68,0)
 ;
"RTN","PSODGDGP",69,0)
BLD I $D(^XUSEC("PSORPH",DUZ)) S PSORX("PHARM")=DUZ D PHARM Q
"RTN","PSODGDGP",70,0)
BLD2 ;
"RTN","PSODGDGP",71,0)
 Q:$P(ON,";")'="O"
"RTN","PSODGDGP",72,0)
 S LSI=$P(^PSRX($P(ON,";",2),0),"^")_"/"_$P(^PSDRUG($P(^PSRX($P(ON,";",2),0),"^",6),0),"^")_","_LSI
"RTN","PSODGDGP",73,0)
 I '$D(^TMP("PSODGI",$J,0)) D
"RTN","PSODGDGP",74,0)
 . S ^TMP("PSODGI",$J,0)=$P(ON,";",2)_","_$G(^TMP("PSODGI",$J,0)),^TMP("PSOSER",$J,0)=IT_","_$G(^TMP("PSOSER",$J,0))
"RTN","PSODGDGP",75,0)
 I ^TMP("PSODGI",$J,0)'[$P(ON,";",2) D
"RTN","PSODGDGP",76,0)
 .S ^TMP("PSODGI",$J,0)=$P(ON,";",2)_","_$G(^TMP("PSODGI",$J,0))
"RTN","PSODGDGP",77,0)
 .S ^TMP("PSOSER",$J,0)=IT_","_$G(^TMP("PSOSER",$J,0))
"RTN","PSODGDGP",78,0)
 I IT=2 S ^TMP("PSOSERS",$J,0)=IT_","_$G(^TMP("PSOSERS",$J,0)),^TMP("PSODGS",$J,0)=$P(ON,";",2)_","_$G(^TMP("PSODGS",$J,0))
"RTN","PSODGDGP",79,0)
 S:IT=1 ^TMP("PSOTDD",$J,1)=1
"RTN","PSODGDGP",80,0)
 Q
"RTN","PSODGDGP",81,0)
PHARM ;pharmacist verification of drug interaction
"RTN","PSODGDGP",82,0)
 S PSODGRLX=$P(ON,";",2)
"RTN","PSODGDGP",83,0)
 S DIR("?",1)="Answer 'YES' if you DO want to "_$S(IT=1:"continue processing",1:"enter an intervention for")_" this medication,"
"RTN","PSODGDGP",84,0)
 S DIR("?")="       'NO' if you DON'T want to "_$S(IT=1:"continue processing",1:"enter an intervention for")_" this medication,"
"RTN","PSODGDGP",85,0)
 W ! S DIR(0)="SA^1:YES;0:NO",DIR("A")="Do you want to "_$S(IT=1:"Continue? ",1:"Intervene? "),DIR("B")="Y" D ^DIR
"RTN","PSODGDGP",86,0)
 I 'Y,IT=1 S PSODLQT=1,DGI="" S:'$G(PSORXED)&('$G(PSOREINS)) PSORX("DFLG")=1 S:$G(PSORXED)!($G(PSOREINS)) PSOQUIT=1 K DIR,DTOUT,DIRUT,DIROUT,DUOUT Q
"RTN","PSODGDGP",87,0)
 I Y,IT=1 S PSORX("INTERVENE")=1,DGI="" K DIR,DTOUT,DIRUT,DIROUT,DUOUT G CRI Q
"RTN","PSODGDGP",88,0)
 I 'Y,IT=2 S:$G(DIRUT) (PSODLQT,PSOQUIT)=1 K DIR,DTOUT,DIRUT,DIROUT,DUOUT D ULRX Q
"RTN","PSODGDGP",89,0)
 I Y,IT=2 S PSORX("INTERVENE")=2,DGI="" K DIR,DTOUT,DIRUT,DIROUT,DUOUT
"RTN","PSODGDGP",90,0)
 D ULRX
"RTN","PSODGDGP",91,0)
 Q
"RTN","PSODGDGP",92,0)
CRI ;process new drug interactions entered by pharmacist
"RTN","PSODGDGP",93,0)
 K DIR ;G:$P(PSOSD(STA,DRG),"^",9) CRITN 
"RTN","PSODGDGP",94,0)
 S DIR("A",1)="",DIR("A",2)="Do you want to Process medication",DIR("A")=PSODRUG("NAME")_": ",DIR(0)="SA^1:PROCESS;0:ABORT ORDER ENTRY",DIR("B")="P"
"RTN","PSODGDGP",95,0)
 S DIR("?",1)="Enter '1' or 'P' to Activate medication",DIR("?")="      '0' or 'A' to Abort Order Entry process" D ^DIR K X1,DIR I 'Y S PSORX("DFLG")=1,DGI="" K DTOUT,DIRUT,DIROUT,DUOUT,PSORX("INTERVENE") D ULRX Q
"RTN","PSODGDGP",96,0)
 I IT=1 D
"RTN","PSODGDGP",97,0)
 .S PSORX("INTERVENE")=IT
"RTN","PSODGDGP",98,0)
 .D SIG^XUSESIG I X1="" K PSORX("INTERVENE") S PSORX("DFLG")=1 Q
"RTN","PSODGDGP",99,0)
 K DUOUT,DTOUT,DIRUT,DIROUT D ULRX Q
"RTN","PSODGDGP",100,0)
CRITN ;process multiple new drug interactions
"RTN","PSODGDGP",101,0)
 K X1,DIR S DIR("A",1)="",DIR("A",2)="Do you want to: ",DIR("A",3)=" 1.  Delete NEW medication "_PSODRUG("NAME"),DIR("A",4)=" 2.  Cancel ACTIVE New Rx #"_$P(^PSRX($P(ON,";",2),0),"^")_" DRUG: "_DRG
"RTN","PSODGDGP",102,0)
 S DIR("A",5)=" 3.  Delete 1 and Cancel 2",DIR("A")=" 4.  Continue ?: ",DIR(0)="SA^1:NEW MEDICATION;2:ACTIVE New Rx "_DRG_";3:BOTH;4:CONTINUE"
"RTN","PSODGDGP",103,0)
 S DIR("?",1)="Enter '1' or 'N' to Delete New Medication and Dispense Rx #"_$P(^PSRX($P(ON,";",2),0),"^")
"RTN","PSODGDGP",104,0)
 S DIR("?",2)="      '2' or 'A' to Cancel Active Rx #"_$P(^PSRX($P(ON,";",2),0),"^")_" and Dispense New Rx"
"RTN","PSODGDGP",105,0)
 S DIR("?",3)="      '3' or 'B' to Delete 1 and Cancel 2",DIR("?")="      '4' or 'C' to do nothing to either Rx" D ^DIR K DIR
"RTN","PSODGDGP",106,0)
 I Y=1 S PSORX("DFLG")=1,DGI="",PSHLDDRG=PSODRUG("IEN") D  D ULRX Q
"RTN","PSODGDGP",107,0)
 .I $G(PSORXED) D  Q
"RTN","PSODGDGP",108,0)
 ..D NOOR^PSOCAN4 I $D(DIRUT) W $C(7)," ACTION NOT TAKEN!",! S PSORX("DFLG")=1 K PSORX("INTERVENE") Q
"RTN","PSODGDGP",109,0)
 ..S DA=$P(ON,";",2) D MESS,ENQ^PSORXDL,FULL^VALM1
"RTN","PSODGDGP",110,0)
 ..K PSOSD($P(PSOLST($P(ON,";",2)),"^",3),PSODRUG("NAME")),DTOUT,DIROUT,DIRUT,DUOUT S:$G(PSOSD) PSOSD=PSOSD-1 S ZONE=1
"RTN","PSODGDGP",111,0)
 .S PSODRUG("IEN")=$P(^PSRX($P(ON,";",2),0),"^",6) D FULL^VALM1,^PSORXI
"RTN","PSODGDGP",112,0)
 .S PSODRUG("IEN")=PSHLDDRG,VALMBCK="R"
"RTN","PSODGDGP",113,0)
 .K DTOUT,DIRUT,DIROUT,DUOUT,PSHLDDRG
"RTN","PSODGDGP",114,0)
 .I $G(OR0) D
"RTN","PSODGDGP",115,0)
 ..D NOOR^PSOCAN4 I $D(DIRUT) D  Q
"RTN","PSODGDGP",116,0)
 ...W $C(7)," ACTION NOT TAKEN!",! K PSORX("INTERVENE") S PSORX("DFLG")=1
"RTN","PSODGDGP",117,0)
 ..D DC^PSOORFI2
"RTN","PSODGDGP",118,0)
 I Y=2 S (DA,PSOHOLDA)=$P(ON,";",2) D  D ULRX Q
"RTN","PSODGDGP",119,0)
 .D NOOR^PSOCAN4 I $D(DIRUT) D  Q
"RTN","PSODGDGP",120,0)
 ..W $C(7)," ACTION NOT TAKEN!",! K PSORX("INTERVENE") S PSORX("DFLG")=1
"RTN","PSODGDGP",121,0)
 .D MESS,ENQ^PSORXDL
"RTN","PSODGDGP",122,0)
 .S DA=PSOHOLDA D FULL^VALM1,EN1^PSORXI(.DA),PPL
"RTN","PSODGDGP",123,0)
 .K DTOUT,DIROUT,DIRUT,DUOUT,PSOHOLDA
"RTN","PSODGDGP",124,0)
 .S:$G(PSOSD) PSOSD=PSOSD-1 S VALMBCK="R"
"RTN","PSODGDGP",125,0)
 I Y=3 S (DA,PSOHOLDA)=$P(ON,";",2) D  S VALMBCK="R"
"RTN","PSODGDGP",126,0)
 .D NOOR^PSOCAN4 I $D(DIRUT) D  Q
"RTN","PSODGDGP",127,0)
 ..W $C(7)," ACTION NOT TAKEN!",! K PSORX("INTERVENE") S PSORX("DFLG")=1
"RTN","PSODGDGP",128,0)
 .S:$G(PSOSD) PSOSD=PSOSD-1 S PSORX("DFLG")=1 D MESS,ENQ^PSORXDL
"RTN","PSODGDGP",129,0)
 .I $G(OR0) D DC^PSOORFI2
"RTN","PSODGDGP",130,0)
 .S DA=PSOHOLDA D FULL^VALM1,EN1^PSORXI(.DA),PPL K PSOHOLDA
"RTN","PSODGDGP",131,0)
 .I $G(PSORXED) D
"RTN","PSODGDGP",132,0)
 ..S DA=$P(ON,";",2) D MESS,ENQ^PSORXDL,FULL^VALM1
"RTN","PSODGDGP",133,0)
 ..K DTOUT,DIROUT,DIRUT,DUOUT S:$G(PSOSD) PSOSD=PSOSD-1 S ZONE=1
"RTN","PSODGDGP",134,0)
 K DTOUT,DIROUT,DIRUT,DUOUT
"RTN","PSODGDGP",135,0)
 D ULRX
"RTN","PSODGDGP",136,0)
 Q
"RTN","PSODGDGP",137,0)
MESS W !!,"Canceling Rx: "_$P($G(^PSRX(DA,0)),"^")_"   "_"Drug: "_$P($G(^PSDRUG($P(^PSRX(DA,0),"^",6),0)),"^"),! Q
"RTN","PSODGDGP",138,0)
PPL F PSOSL=0:0 S PSOSL=$O(PSORX("PSOL",PSOSL)) Q:'PSOSL  S PSOX2=PSOSL
"RTN","PSODGDGP",139,0)
 I $G(PSOX2) D
"RTN","PSODGDGP",140,0)
 .F PSOSL=0:1:PSOX2 S PSOSL=$O(PSORX("PSOL",PSOSL)) Q:'PSOSL  F ENT=1:1:$L(PSORX("PSOL",PSOSL),",") I $P(PSORX("PSOL",PSOSL),",",ENT)=$P(ON,";",2) S PSOL(PSOSL,ENT)=""
"RTN","PSODGDGP",141,0)
 .F PSOL=0:0 S PSOL=$O(PSOL(PSOL)) Q:'PSOL  F ENT=0:0 S ENT=$O(PSOL(PSOL,ENT)) Q:'ENT  D
"RTN","PSODGDGP",142,0)
 ..I ENT=1,'$P(PSORX("PSOL",PSOL),",",2) K PSORX("PSOL",PSOL) Q
"RTN","PSODGDGP",143,0)
 ..I ENT=1,$P(PSORX("PSOL",PSOL),",",2) S PSORX("PSOL",PSOL)=$P(PSORX("PSOL",PSOL),",",2,99) Q
"RTN","PSODGDGP",144,0)
 ..S PSORX("PSOL",PSOL)=$P(PSORX("PSOL",PSOL),",",1,ENT-1)_","_$P(PSORX("PSOL",PSOL),",",ENT+1,99)
"RTN","PSODGDGP",145,0)
 K PSOX2,PSOSL,PSOL,ENT Q
"RTN","PSODGDGP",146,0)
ULRX ;
"RTN","PSODGDGP",147,0)
 I '$G(PSODGRLX) Q
"RTN","PSODGDGP",148,0)
 D PSOUL^PSSLOCK(PSODGRLX) K PSODGRLX
"RTN","PSODGDGP",149,0)
 Q
"RTN","PSODIR")
0^18^B34162228^B28488189
"RTN","PSODIR",1,0)
PSODIR ;BHAM ISC/SAB - asks data for rx order entry ; 9/17/07 5:03pm
"RTN","PSODIR",2,0)
 ;;7.0;OUTPATIENT PHARMACY;**37,46,111,117,146,164,211,264,275,391**;DEC 1997;Build 13
"RTN","PSODIR",3,0)
 ;External reference PSDRUG( supported by DBIA 221
"RTN","PSODIR",4,0)
 ;External reference PS(50.7 supported by DBIA 2223
"RTN","PSODIR",5,0)
 ;External reference to VA(200 is supported by DBIA 10060
"RTN","PSODIR",6,0)
 ;----------------------------------------------------------------
"RTN","PSODIR",7,0)
 ;
"RTN","PSODIR",8,0)
PROV(PSODIR) ;
"RTN","PSODIR",9,0)
PROVEN ; Entry point for failed lookup
"RTN","PSODIR",10,0)
 K DIC,X,Y S:$G(PSOFDR)&($G(OR0)) DIC("B")=$P(^VA(200,$P($G(OR0),"^",5),0),"^")
"RTN","PSODIR",11,0)
 I '$D(PSODIR("CS")),$D(PSODRUG("DEA")) D
"RTN","PSODIR",12,0)
 .N DEA S PSODIR("CS")=0 F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S PSODIR("CS")=1
"RTN","PSODIR",13,0)
 I $G(PSODIR("PROVIDER"))]"" S PSODIR("OLD VAL")=PSODIR("PROVIDER")
"RTN","PSODIR",14,0)
 S DIC="^VA(200,",DIC(0)="QEAM",PSODIR("FIELD")=0
"RTN","PSODIR",15,0)
 S DIC("W")="W ""     "",$P(^(""PS""),""^"",9)"
"RTN","PSODIR",16,0)
 S DIC("A")="PROVIDER: ",DIC("S")="I $D(^(""PS"")),$P(^(""PS""),""^""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)'<DT)"
"RTN","PSODIR",17,0)
 I $G(PSOTPBFG),$G(PSOFROM)="NEW" S DIC("S")=DIC("S")_",$P($G(^(""TPB"")),""^""),$P($G(^(""TPB"")),""^"",5)=0"
"RTN","PSODIR",18,0)
 S:$G(PSORX("PROVIDER NAME"))]"" DIC("B")=PSORX("PROVIDER NAME")
"RTN","PSODIR",19,0)
 D ^DIC K DIC
"RTN","PSODIR",20,0)
 I X[U,$L(X)>1 D:'$G(PSOEDIT) JUMP G PROVX
"RTN","PSODIR",21,0)
 I $D(DTOUT)!$D(DUOUT) S PSODIR("DFLG")=1 G PROVX
"RTN","PSODIR",22,0)
 I '$G(SPEED),Y=-1 G PROVEN
"RTN","PSODIR",23,0)
 Q:$G(SPEED)&(Y=-1)
"RTN","PSODIR",24,0)
 ;PSO*7*211; ADD CHECK FOR DEA# AND VA#
"RTN","PSODIR",25,0)
 I $P($G(PSODIR("CS")),"^",1)!($D(CLOZPAT)) N NDEA,SDEA S SDEA=$$DRGSCH() S NDEA=$$SDEA^XUSER(0,+Y,SDEA) I $L($P(NDEA,"^"))<3 D  G PROVEN
"RTN","PSODIR",26,0)
 .I NDEA=2 W $C(7),!!,"Provider not authorized to write Federal Schedule "_SDEA_" prescriptions.",! Q
"RTN","PSODIR",27,0)
 .W $C(7),!!,"Provider must have a DEA# or VA# to write prescriptions for this drug.",!
"RTN","PSODIR",28,0)
 ;PSO*7.0*391; Added check for DETOX#
"RTN","PSODIR",29,0)
 I $$DETOX^PSSOPKI($G(PSODRUG("IEN"))),$$DETOX^XUSER(+Y)="" W $C(7),!!,"Provider must have a DETOX# to order this drug.",! G PROVEN
"RTN","PSODIR",30,0)
 I $D(CLOZPAT),'$D(^XUSEC("YSCL AUTHORIZED",+Y)) D  G PROVEN
"RTN","PSODIR",31,0)
 .W $C(7),!!,"Provider must hold YSCL AUTHORIZED key to write prescriptions for clozapine.",!
"RTN","PSODIR",32,0)
 I '$G(PSODRUG("IEN")),'$G(PSORENW("DRUG IEN")) G NODRUG
"RTN","PSODIR",33,0)
NODRUG S PSODIR("PROVIDER")=+Y
"RTN","PSODIR",34,0)
 S (PSODIR("PROVIDER NAME"),PSORX("PROVIDER NAME"))=$P(Y,"^",2)
"RTN","PSODIR",35,0)
 I $G(PSODIR("OLD VAL"))'=+Y K PSODIR("GENERIC PROVIDER"),PSODIR("COSIGNING PROVIDER")
"RTN","PSODIR",36,0)
 I $G(PSODIR("OLD VAL"))'=$G(PSODIR("PROVIDER")),$P(Y,"^",2)="PROVIDER,OTHER"!($P(Y,"^",2)="PROVIDER,OUTSIDE") D GENERIC
"RTN","PSODIR",37,0)
 I $P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",7),$P(^("PS"),"^",8) D COSIGN
"RTN","PSODIR",38,0)
 I $G(PSODIR("COSIGNING PROVIDER")),'$P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",7) K PSODIR("COSIGNING PROVIDER")
"RTN","PSODIR",39,0)
PROVX K X,Y
"RTN","PSODIR",40,0)
 Q
"RTN","PSODIR",41,0)
 ;
"RTN","PSODIR",42,0)
DRGSCH() ; determine the drug schedule
"RTN","PSODIR",43,0)
 N ND3,SCH
"RTN","PSODIR",44,0)
 S SCH="",ND3=$P($G(^PSDRUG(PSODRUG("IEN"),"ND")),"^",3) S:+ND3 SCH=$$GET1^DIQ(50.68,ND3,19,"I")
"RTN","PSODIR",45,0)
 I +SCH>0!($G(PSODRUG("DEA"))="") Q SCH
"RTN","PSODIR",46,0)
 I "^4^5^"[+PSODRUG("DEA") Q +PSODRUG("DEA")
"RTN","PSODIR",47,0)
 Q $S($G(PSODRUG("DEA"))["A":+PSODRUG("DEA"),1:+PSODRUG("DEA")_"n")
"RTN","PSODIR",48,0)
 ;
"RTN","PSODIR",49,0)
GENERIC ;
"RTN","PSODIR",50,0)
 K DIR,DIC,PSODIR("GENERIC PROVIDER")
"RTN","PSODIR",51,0)
 S DIR(0)="52,30"
"RTN","PSODIR",52,0)
 D DIR G:PSODIR("DFLG")!PSODIR("FIELD") GENERICX
"RTN","PSODIR",53,0)
 S PSODIR("GENERIC PROVIDER")=Y
"RTN","PSODIR",54,0)
GENERICX K X,Y
"RTN","PSODIR",55,0)
 Q
"RTN","PSODIR",56,0)
 ;
"RTN","PSODIR",57,0)
COSIGN ;
"RTN","PSODIR",58,0)
 K DIC
"RTN","PSODIR",59,0)
 I '$G(PSODIR("COSIGNING PROVIDER")),$P($G(RX3),"^",3) S PSODIR("COSIGNING PROVIDER")=$P(RX3,"^",3) G COSIGN1
"RTN","PSODIR",60,0)
 I $P($G(RX3),"^",3),$P($G(RX3),"^",3)'=$P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",8) D
"RTN","PSODIR",61,0)
 .W !!,"Previous Co-Signing Provider: "_$P(^VA(200,$P(RX3,"^",3),0),"^")
"RTN","PSODIR",62,0)
 .S PSODIR("COSIGNING PROVIDER")=$S($P(RX3,"^",3)'=PSODIR("COSIGNING PROVIDER"):PSODIR("COSIGNING PROVIDER"),1:$P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",8))
"RTN","PSODIR",63,0)
COSIGN1 S DIC(0)="QEAM",DIC="^VA(200,",DIC("B")=$S($G(PSODIR("COSIGNING PROVIDER")):$P(^VA(200,PSODIR("COSIGNING PROVIDER"),0),"^"),1:$P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",8))
"RTN","PSODIR",64,0)
 S DIC("S")="I $D(^(""PS"")),$P(^(""PS""),""^""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)'<DT)"
"RTN","PSODIR",65,0)
 S DIC("W")="W ""     "",$P(^(""PS""),""^"",9)",DIC("S")=DIC("S")_",'$P(^(""PS""),""^"",7)"
"RTN","PSODIR",66,0)
 S DIC("A")="COSIGNING PROVIDER: " D ^DIC K DIC
"RTN","PSODIR",67,0)
 I $D(DTOUT)!$D(DUOUT) S PSODIR("DFLG")=1 G COSIGNX
"RTN","PSODIR",68,0)
 S:+Y>0 PSODIR("COSIGNING PROVIDER")=+Y G:Y<0 COSIGN
"RTN","PSODIR",69,0)
COSIGNX K X,Y
"RTN","PSODIR",70,0)
 Q
"RTN","PSODIR",71,0)
DOSE(PSODIR) ;add dosing info
"RTN","PSODIR",72,0)
 D DOSE1^PSOORED5(.PSODIR)
"RTN","PSODIR",73,0)
EX K PSODOSE,PSOSCH,DOSE,DOOR,SCH,VERB,NOUN,DOSEOR,ENT,PSORTE,DRUA,DIR,X,Y,DIRUT,RTE,ERTE,DD,INS1,SINS1
"RTN","PSODIR",74,0)
 Q
"RTN","PSODIR",75,0)
INS(PSODIR) ;patient instructions
"RTN","PSODIR",76,0)
 N DA K INS1,DD,DIR,DIRUT S D=0 F  S D=$O(PSODIR("SIG",D)) Q:'D  S DD=$G(DD)+1
"RTN","PSODIR",77,0)
 I $G(DD)=1 S PSODIR("INS")=$G(PSODIR("SIG",1)) G INSD
"RTN","PSODIR",78,0)
 ;PSO*7*275 remove check for PSOINSFL just check for multi line sig
"RTN","PSODIR",79,0)
 I $G(DD)>1 D  G EX
"RTN","PSODIR",80,0)
 .K ^TMP($J) S D=0 F  S D=$O(PSODIR("SIG",D)) Q:'D  S ^TMP($J,"SIG",D,0)=PSODIR("SIG",D)
"RTN","PSODIR",81,0)
 .S DWPK=2,DWLW=80,DIC="^TMP($J,""SIG""," D EN^DIWE K PSODIR("SIG")
"RTN","PSODIR",82,0)
 .S D=0 F  S D=$O(^TMP($J,"SIG",D)) Q:'D  S PSODIR("SIG",D)=^TMP($J,"SIG",D,0)
"RTN","PSODIR",83,0)
 .D EN^PSOFSIG(.PSODIR,1) K DWLW,D,DWPK,^TMP($J)
"RTN","PSODIR",84,0)
 I $G(PSOINSFL)=0 G INSD
"RTN","PSODIR",85,0)
 I $G(PSOFDR),$G(ORD),$P($G(^PS(52.41,+$G(ORD),"EXT")),"^")'="" G INSD
"RTN","PSODIR",86,0)
 I $G(PSODIR("INS"))']"",$G(^PS(50.7,PSODRUG("OI"),"INS"))]"" S DIR("B")=^PS(50.7,PSODRUG("OI"),"INS")
"RTN","PSODIR",87,0)
INSD S DIR(0)="52,114" S:$G(PSODIR("INS"))]"" DIR("B")=PSODIR("INS")
"RTN","PSODIR",88,0)
 D DIR G:$G(PSODIR("DFLG"))!(PSODIR("FIELD")) EX
"RTN","PSODIR",89,0)
 I X'="",X'="@" S PSODIR("INS")=Y D SIG^PSOHELP G INSD:'$D(X)
"RTN","PSODIR",90,0)
 I $G(INS1)]"" D EN^DDIOL($E(INS1,2,9999999)) S (PSODIR("SIG",1),PSODIR("SIG"))=$E(INS1,2,9999999)
"RTN","PSODIR",91,0)
 I X="@" K PSODIR("INS"),PSODIR("SIG")
"RTN","PSODIR",92,0)
 D EN^PSOFSIG(.PSODIR,1) I $O(SIG(0)) S SIGOK=1
"RTN","PSODIR",93,0)
 G EX
"RTN","PSODIR",94,0)
 Q
"RTN","PSODIR",95,0)
SINS(PSODIR) ;other lang. patient instructions
"RTN","PSODIR",96,0)
 K SINS1,DIR
"RTN","PSODIR",97,0)
 S DIR(0)="52,114.1" S:$G(PSODIR("SINS"))]"" DIR("B")=PSODIR("SINS")
"RTN","PSODIR",98,0)
 I $G(PSODIR("SINS"))']"",$G(^PS(50.7,PSODRUG("OI"),"INS1"))]"" S DIR("B")=^PS(50.7,PSODRUG("OI"),"INS1")
"RTN","PSODIR",99,0)
 D DIR G:$G(PSODIR("DFLG")) EX
"RTN","PSODIR",100,0)
 I X'="",X'="@" S PSODIR("SINS")=Y D SSIG^PSOHELP
"RTN","PSODIR",101,0)
 I $G(SINS1)]"" D EN^DDIOL($E(SINS1,2,9999999)) S PSODIR("SINS")=$E(SINS1,2,9999999)
"RTN","PSODIR",102,0)
 I X="@" K PSODIR("SINS")
"RTN","PSODIR",103,0)
 G EX
"RTN","PSODIR",104,0)
 Q
"RTN","PSODIR",105,0)
 ;
"RTN","PSODIR",106,0)
DIR ;
"RTN","PSODIR",107,0)
 S PSODIR("FIELD")=0
"RTN","PSODIR",108,0)
 G:$G(DIR(0))']"" DIRX
"RTN","PSODIR",109,0)
 D ^DIR K DIR,DIE,DIC,DA
"RTN","PSODIR",110,0)
 I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)),$L($G(X))'>1 S PSODIR("DFLG")=1 G DIRX
"RTN","PSODIR",111,0)
 I X[U,$L(X)>1 D:'$G(PSOEDIT) JUMP
"RTN","PSODIR",112,0)
DIRX K DIRUT,DTOUT,DUOUT,DIROUT,PSOX
"RTN","PSODIR",113,0)
 Q
"RTN","PSODIR",114,0)
 ;
"RTN","PSODIR",115,0)
JUMP ;
"RTN","PSODIR",116,0)
 I $G(PSOEDIT)!($G(OR0)) S PSODIR("DFLG")=1 Q
"RTN","PSODIR",117,0)
 S X=$P(X,"^",2),DIC="^DD(52,",DIC(0)="QM" D ^DIC K DIC
"RTN","PSODIR",118,0)
 I Y=-1 S PSODIR("FIELD")=$G(PSODIR("FLD")) G JUMPX
"RTN","PSODIR",119,0)
 I $G(PSONEW1)=0 D JUMP^PSONEW1 G JUMPX
"RTN","PSODIR",120,0)
 I $G(PSOREF1)=0 D JUMP^PSOREF1 G JUMPX
"RTN","PSODIR",121,0)
 I $G(PSONEW3)=0 D JUMP^PSONEW3 G JUMPX
"RTN","PSODIR",122,0)
 I $G(PSORENW3)=0 D JUMP^PSORENW3 G JUMPX
"RTN","PSODIR",123,0)
JUMPX S X="^"_X
"RTN","PSODIR",124,0)
 Q
"RTN","PSODIR1")
0^35^B94639325^B86466009
"RTN","PSODIR1",1,0)
PSODIR1 ;IHS/DSD - ASKS DATA FOR RX ORDER ENTRY CONT. ; 5/18/10 2:28pm
"RTN","PSODIR1",2,0)
 ;;7.0;OUTPATIENT PHARMACY;**23,46,78,102,121,131,146,166,184,222,268,206,266,340,391**;DEC 1997;Build 13
"RTN","PSODIR1",3,0)
 ;Ext ref ^PS(55-DBIA 2228, ^PSDRUG(-DBIA 221
"RTN","PSODIR1",4,0)
PTSTAT(PSODIR) ;
"RTN","PSODIR1",5,0)
PTSTATEN K DIC,DR,DIE S PSODIR("FIELD")=0
"RTN","PSODIR1",6,0)
 I $G(PSOTPBFG),$G(PSOFROM)="NEW" K PSORX("PATIENT STATUS"),PSODIR("PATIENT STATUS") N PSOFNDRX,PSOFNDFL,PSOFNDPS D
"RTN","PSODIR1",7,0)
 .S PSOFNDFL=0 F PSOFNDPS=0:0 S PSOFNDPS=$O(^PS(53,PSOFNDPS)) Q:'PSOFNDPS!(PSOFNDFL)  D
"RTN","PSODIR1",8,0)
 ..S PSOFNDRX=$P($G(^PS(53,PSOFNDPS,0)),"^") S PSOFNDRX=$$UP^XLFSTR(PSOFNDRX) I PSOFNDRX="NON-VA" S PSOFNDFL=1 S (PSORX("PATIENT STATUS"),DIC("B"))=$P($G(^PS(53,PSOFNDPS,0)),"^")
"RTN","PSODIR1",9,0)
 I $G(PSOTPBFG),$G(PSOFROM)="NEW",$G(PSORX("PATIENT STATUS"))="" W !,"Could not find a 'NON-VA' Patient Status in the RX PATIENT STATUS file (#53)!" D PSTPB D  S PSODIR("DFLG")=1 G PTSTATX
"RTN","PSODIR1",10,0)
 .K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
"RTN","PSODIR1",11,0)
 I $G(PSOTPBFG),$G(PSOFROM)="NEW" G TPBB
"RTN","PSODIR1",12,0)
 N PSOX
"RTN","PSODIR1",13,0)
 S PSOX=$G(^PS(55,PSODFN,"PS")) I PSOX]"" S PSORX("PATIENT STATUS")=$P($G(^PS(53,PSOX,0)),"^"),DIC("B")=PSORX("PATIENT STATUS")
"RTN","PSODIR1",14,0)
 S:$G(PSODIR("PATIENT STATUS"))]"" DIC("B")=PSODIR("PATIENT STATUS")
"RTN","PSODIR1",15,0)
TPBB ;
"RTN","PSODIR1",16,0)
 D ELIG^VADPT W !,"Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):"     SC%: "_$P(VAEL(3),"^",2),1:"")
"RTN","PSODIR1",17,0)
 S N=0 F  S N=$O(VAEL(1,N)) Q:'N  W !,?10,$P(VAEL(1,N),"^",2)
"RTN","PSODIR1",18,0)
 S DIC("A")="RX PATIENT STATUS: "
"RTN","PSODIR1",19,0)
 S DIC(0)="QEAMZ",DIC=53 D ^DIC K DIC
"RTN","PSODIR1",20,0)
 I $G(PSOTPBFG),$G(PSOFROM)="NEW" N PSOPSDIR,PSOFNDZZ,PSOPSUPA S (PSOPSDIR,PSOPSUPA)=0 D  I PSOPSDIR S:PSOPSUPA PSODIR("DFLG")=1 G:PSOPSUPA PTSTATX W ! D PSTPB G PTSTATEN
"RTN","PSODIR1",21,0)
 .I +Y'>0!($D(DTOUT))!($D(DUOUT)) S (PSOPSDIR,PSOPSUPA)=1 Q
"RTN","PSODIR1",22,0)
 .S (PSODIR("PATIENT STATUS"),PSORX("PATIENT STATUS"))=+Y,PSODIR("PTST NODE")=Y(0)
"RTN","PSODIR1",23,0)
 .S PSOFNDZZ=$P($G(^PS(53,+Y,0)),"^") S PSOFNDZZ=$$UP^XLFSTR(PSOFNDZZ) I PSOFNDZZ'="NON-VA" S PSOPSDIR=1 K PSODIR("PATIENT STATUS"),PSORX("PATIENT STATUS"),PSODIR("PTST NODE")
"RTN","PSODIR1",24,0)
 I $G(PSOTPBFG),$G(PSOFROM)="NEW" G TPBSC
"RTN","PSODIR1",25,0)
 I X[U,$L(X)>1 D:'$G(PSOEDIT) JUMP G PTSTATX
"RTN","PSODIR1",26,0)
 I $D(DUOUT)!$D(DTOUT) S PSODIR("DFLG")=1 G PTSTATX
"RTN","PSODIR1",27,0)
 I Y=-1 W $C(7)," Required" G PTSTATEN
"RTN","PSODIR1",28,0)
 N PSOFNDX,PSOFNDXY,PSOFNDXX,PSOFNDYY
"RTN","PSODIR1",29,0)
 S PSOFNDXY=$G(Y),PSOFNDYY=$G(Y(0))
"RTN","PSODIR1",30,0)
 I '$G(PSOTPBFG),$G(PSOFROM)="NEW" S PSOFNDX=$P($G(^PS(53,+Y,0)),"^") S PSOFNDXX=$$UP^XLFSTR(PSOFNDX) I PSOFNDXX="NON-VA" K PSOFNDX,PSOFNDXY,PSOFNDYY,PSOFNDXX,Y W !!,"Cannot select 'NON-VA' Rx Patient Status!",! G PTSTATEN
"RTN","PSODIR1",31,0)
 S Y=$G(PSOFNDXY),Y(0)=$G(PSOFNDYY)
"RTN","PSODIR1",32,0)
 K PSOFNDXY,PSOFNDYY,PSOFNDX,PSOFNDXX
"RTN","PSODIR1",33,0)
 S (PSODIR("PATIENT STATUS"),PSORX("PATIENT STATUS"))=+Y
"RTN","PSODIR1",34,0)
 S PSODIR("PTST NODE")=Y(0)
"RTN","PSODIR1",35,0)
TPBSC ;
"RTN","PSODIR1",36,0)
 I $G(PSOFDR),$P($G(OR0),"^",17)="C" G PTSTATX
"RTN","PSODIR1",37,0)
 L +^PS(55,PSODFN):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T G PTSTATX
"RTN","PSODIR1",38,0)
 S DIE="55",DR="3////"_+Y,DA=PSODFN D ^DIE K DIE,DA,D0
"RTN","PSODIR1",39,0)
 L -^PS(55,PSODFN)
"RTN","PSODIR1",40,0)
PTSTATX K DTOUT,DUOUT,X,Y,DA
"RTN","PSODIR1",41,0)
 Q
"RTN","PSODIR1",42,0)
SIG(PSODIR) ;
"RTN","PSODIR1",43,0)
 I $G(PSOFDR),$G(PSODIR("SIG"))']"" D SIGOK G:$G(SIGOK)!($G(PSODIR("DFLG"))) SIGX
"RTN","PSODIR1",44,0)
 K DIR,DIC
"RTN","PSODIR1",45,0)
 S DIR(0)="52,10"
"RTN","PSODIR1",46,0)
 S:$G(PSODRUG("SIG"))]"" DIR("B")=PSODRUG("SIG")
"RTN","PSODIR1",47,0)
 S:$G(PSODIR("SIG"))]"" DIR("B")=PSODIR("SIG")
"RTN","PSODIR1",48,0)
 D DIR G:PSODIR("DFLG")!PSODIR("FIELD") SIGX
"RTN","PSODIR1",49,0)
 S PSODIR("SIG")=Y,SIGOK=0 K SIG
"RTN","PSODIR1",50,0)
SIGX K X,Y
"RTN","PSODIR1",51,0)
 Q
"RTN","PSODIR1",52,0)
QTY(PSODIR) ;
"RTN","PSODIR1",53,0)
QTYA K DIR,DIC
"RTN","PSODIR1",54,0)
 I $G(CLOZPAT)=1 S DIR("A",1)="Patient Eligible for 14 day supply or 7 day supply with 1 refill"
"RTN","PSODIR1",55,0)
 I $G(CLOZPAT)=2 S DIR("A",1)="Patient Eligible 28 day supply or 14 day supply with 1 refill or 7 day supply with 3 refill"
"RTN","PSODIR1",56,0)
 S DIR(0)="52,7" S:$G(PSODRUG("IEN")) DIR("A")="QTY ( "_$G(PSODRUG("UNIT"))_" ) "_$S($P($G(^PSDRUG(+PSODRUG("IEN"),5)),"^")]"":$P(^PSDRUG(+PSODRUG("IEN"),5),"^"),1:"")
"RTN","PSODIR1",57,0)
 K QTYHLD I $G(PSODIR("QTY"))]"" S QTYHLD=PSODIR("QTY") K PSODIR("QTY")
"RTN","PSODIR1",58,0)
 D:'$G(PSOQTY) QTY^PSOSIG(.PSODIR)
"RTN","PSODIR1",59,0)
 I '$G(SPEED),$G(QTYHLD),'$G(PSODIR("QTY")) S PSODIR("QTY")=QTYHLD
"RTN","PSODIR1",60,0)
 K QTYHLD K:'$G(PSODIR("QTY")) PSODIR("QTY")
"RTN","PSODIR1",61,0)
 I $G(SPEED),$G(PSODIR("QTY"))']"" S PSODIR("QTY")=$P(^PSRX(PSORENW("OIRXN"),0),"^",7)
"RTN","PSODIR1",62,0)
 S:$G(PSODIR("QTY"))]"" DIR("B")=PSODIR("QTY")
"RTN","PSODIR1",63,0)
 D DIR G:PSODIR("DFLG")!PSODIR("FIELD") QTYX
"RTN","PSODIR1",64,0)
 I $G(Y),$G(PSODRUG("MAXDOSE"))]"",$G(PSODIR("DAYS SUPPLY")),(Y/+PSODIR("DAYS SUPPLY")>PSODRUG("MAXDOSE")) D  G:$G(PSODIR("DFLG")) QTYX  G QTYA
"RTN","PSODIR1",65,0)
 .W !,$C(7)," Greater than Maximum dose of "_PSODRUG("MAXDOSE")_" per day" D DAYSEN
"RTN","PSODIR1",66,0)
 I $G(PSOFDR),$P($G(OR0),"^",24),$G(PSODIR("QTY")),+Y>$G(PSODIR("QTY")) D  G QTYX
"RTN","PSODIR1",67,0)
 .W !!,"Digitally Signed Order - QTY cannot be increased",!
"RTN","PSODIR1",68,0)
 .N DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR W !
"RTN","PSODIR1",69,0)
 S PSODIR("QTY")=Y
"RTN","PSODIR1",70,0)
QTYX K X,Y
"RTN","PSODIR1",71,0)
 Q
"RTN","PSODIR1",72,0)
COPIES(PSODIR) ;
"RTN","PSODIR1",73,0)
 K DIR,DIC
"RTN","PSODIR1",74,0)
 S DIR(0)="52,10.6"
"RTN","PSODIR1",75,0)
 S DIR("B")=$S($G(PSODIR("COPIES"))]"":PSODIR("COPIES"),1:1)
"RTN","PSODIR1",76,0)
 D DIR G:PSODIR("DFLG")!PSODIR("FIELD") COPIESX
"RTN","PSODIR1",77,0)
 S PSODIR("COPIES")=Y
"RTN","PSODIR1",78,0)
COPIESX K X,Y
"RTN","PSODIR1",79,0)
 Q
"RTN","PSODIR1",80,0)
DAYS(PSODIR) ;
"RTN","PSODIR1",81,0)
DAYSEN K DIR,DIC N PSORFLS
"RTN","PSODIR1",82,0)
 ;PSO*7*266
"RTN","PSODIR1",83,0)
 N S2DS S S2DS=0
"RTN","PSODIR1",84,0)
 I $D(PSODRUG("IEN")) D
"RTN","PSODIR1",85,0)
 .S S2DS=$$CSDS^PSOSIGDS(PSODRUG("IEN")) I S2DS,$P($G(PSODIR("PTST NODE")),"^",3)>29 S S2DS=30
"RTN","PSODIR1",86,0)
 .S PSORFLS=$S($G(PSODIR("# OF REFILLS")):PSODIR("# OF REFILLS"),1:$P($G(PSODIR("RX0")),"^",9))
"RTN","PSODIR1",87,0)
 .I '$D(PSODRUG("DEA")) S PSODRUG("DEA")=$$GET1^DIQ(50,PSODRUG("IEN"),3,"")
"RTN","PSODIR1",88,0)
 S DIR(0)="N^1:"_$S($G(CLOZPAT)=2:28,$G(CLOZPAT)=1:14,$G(CLOZPAT)=0:7,1:90)
"RTN","PSODIR1",89,0)
 S DIR("B")=$S($D(CLOZPAT)&('$G(PSODIR("DAYS SUPPLY"))):7,$G(PSODIR("DAYS SUPPLY"))]"":PSODIR("DAYS SUPPLY"),S2DS>1:S2DS,$P($G(PSODIR("PTST NODE")),"^",3):$P(PSODIR("PTST NODE"),"^",3),1:30)
"RTN","PSODIR1",90,0)
 S DIR("A")="DAYS SUPPLY",DIR("?")="Enter a whole number between 1 and "_$S($G(CLOZPAT)=2:28,$G(CLOZPAT)=1:14,$G(CLOZPAT)=0:7,1:90)
"RTN","PSODIR1",91,0)
 D DIR G:PSODIR("DFLG")!PSODIR("FIELD") DAYSX
"RTN","PSODIR1",92,0)
 I $G(Y),$G(PSODRUG("MAXDOSE"))]"",$G(PSODIR("QTY"))]"",(+PSODIR("QTY")/Y>PSODRUG("MAXDOSE")) W !,$C(7)," Greater than Maximum dose of "_PSODRUG("MAXDOSE")_" per day" G DAYSEN
"RTN","PSODIR1",93,0)
 I $G(PSOFDR),$P($G(OR0),"^",24),$G(PSODIR("DAYS SUPPLY")),+Y>$G(PSODIR("DAYS SUPPLY")) D  G DAYSX
"RTN","PSODIR1",94,0)
 .W !!,"Digitally Signed Order - Days Supply cannot be increased",!
"RTN","PSODIR1",95,0)
 .N DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR W !
"RTN","PSODIR1",96,0)
 I $G(PSONEW("FLD"))=8,PSODIR("DAYS SUPPLY")=Y Q
"RTN","PSODIR1",97,0)
 S PSODIR("DAYS SUPPLY")=Y
"RTN","PSODIR1",98,0)
 ;PSO*7*266
"RTN","PSODIR1",99,0)
 I $D(PSODRUG("IEN")),$G(Y),($G(Y)>$S(PSORFLS<4:90,PSORFLS<6:89,PSORFLS<12:60,1:0)) D
"RTN","PSODIR1",100,0)
 .W !,$C(7),"Invalid number of REFILLS for amount of DAYS SUPPLY.",!,"REFILL EDIT FORCED." D REFILL(.PSODIR)
"RTN","PSODIR1",101,0)
 .S PSODIR("FLD",9)=PSODIR("# OF REFILLS")
"RTN","PSODIR1",102,0)
 D:$G(PSOFROM)="NEW"
"RTN","PSODIR1",103,0)
 .K QTYHLD S:$G(PSODIR("QTY")) QTYHLD=PSODIR("QTY") D QTY^PSOSIG(.PSODIR)
"RTN","PSODIR1",104,0)
 .I $G(QTYHLD),'$G(PSODIR("QTY")) S PSODIR("QTY")=QTYHLD
"RTN","PSODIR1",105,0)
 .K QTYHLD K:'$G(PSODIR("QTY")) PSODIR("QTY")
"RTN","PSODIR1",106,0)
 S:$G(CLOZPAT)=0 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=0
"RTN","PSODIR1",107,0)
 D:$G(CLOZPAT)=2
"RTN","PSODIR1",108,0)
 .S:PSODIR("DAYS SUPPLY")=28 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=0
"RTN","PSODIR1",109,0)
 .S:PSODIR("DAYS SUPPLY")=14 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=1
"RTN","PSODIR1",110,0)
 .S:PSODIR("DAYS SUPPLY")=7 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=3
"RTN","PSODIR1",111,0)
 D:$G(CLOZPAT)=1
"RTN","PSODIR1",112,0)
 .S:PSODIR("DAYS SUPPLY")=14 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=0
"RTN","PSODIR1",113,0)
 .S:PSODIR("DAYS SUPPLY")=7 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=1
"RTN","PSODIR1",114,0)
 K QTYHLD S:$G(PSODIR("QTY")) QTYHLD=PSODIR("QTY") D QTY^PSOSIG(.PSODIR)
"RTN","PSODIR1",115,0)
 I $G(QTYHLD),'$G(PSODIR("QTY")) S PSODIR("QTY")=QTYHLD
"RTN","PSODIR1",116,0)
 K QTYHLD K:'$G(PSODIR("QTY")) PSODIR("QTY")
"RTN","PSODIR1",117,0)
DAYSX K X,Y
"RTN","PSODIR1",118,0)
 Q
"RTN","PSODIR1",119,0)
REFILL(PSODIR) ;
"RTN","PSODIR1",120,0)
 ;PSO*7*340 Recalculate RFTT if it doesn't exist
"RTN","PSODIR1",121,0)
 I '$G(PSONEW) D
"RTN","PSODIR1",122,0)
 .N I I '$G(RFTT),$G(PSORXED("IRXN")) F I=0:0 S I=$O(^PSRX(PSORXED("IRXN"),1,I)) Q:'I  S RFTT=$G(RFTT)+1
"RTN","PSODIR1",123,0)
 ;PSO*7*266
"RTN","PSODIR1",124,0)
 I $G(PSODIR("PTST NODE"))="" D
"RTN","PSODIR1",125,0)
 .N X,Y
"RTN","PSODIR1",126,0)
 .S X=$G(PSODIR("PATIENT STATUS")) S:'X X=$P(RX0,"^",3)
"RTN","PSODIR1",127,0)
 .S DIC=53,DIC(0)="QXZ" D ^DIC K DIC
"RTN","PSODIR1",128,0)
 .S:+Y PSODIR("PTST NODE")=Y(0)
"RTN","PSODIR1",129,0)
 .S:'$G(PSODIR("PATIENT STATUS")) PSODIR("PATIENT STATUS")=+Y
"RTN","PSODIR1",130,0)
 S $P(PSODIR("PTST NODE"),"^",4)=+$P($G(PSODIR("PTST NODE")),"^",4)
"RTN","PSODIR1",131,0)
 I $G(OR0) G REFOR
"RTN","PSODIR1",132,0)
 S PSODIR("CS")=0 K DIR,DIC,PSOX
"RTN","PSODIR1",133,0)
 F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSODIR("CS"),"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSODIR("CS"),"^",2)=1
"RTN","PSODIR1",134,0)
 I PSODIR("CS") D
"RTN","PSODIR1",135,0)
 .S PSOX=5,PSOX1=$S($P($G(PSODIR("PTST NODE")),"^",4)>PSOX:PSOX,1:$P($G(PSODIR("PTST NODE")),"^",4)),PSOX=$S(PSOX1=5:PSOX,1:PSOX1)
"RTN","PSODIR1",136,0)
 .S PSOX=$S('PSOX:0,PSODIR("DAYS SUPPLY")=90:1,1:PSOX),PSDY=PSODIR("DAYS SUPPLY"),PSDY1=$S(PSDY<60:5,PSDY'<60&(PSDY'>89):2,PSDY=90:1,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
"RTN","PSODIR1",137,0)
 E  D
"RTN","PSODIR1",138,0)
 .S PSOX=11,PSOX1=$S($P($G(PSODIR("PTST NODE")),"^",4)>PSOX:PSOX,1:$P($G(PSODIR("PTST NODE")),"^",4)),PSOX=$S(PSOX1=11:PSOX,1:PSOX1)
"RTN","PSODIR1",139,0)
 .S PSDY=PSODIR("DAYS SUPPLY"),PSDY1=$S(PSDY<60:11,PSDY'<60&(PSDY'>89):5,PSDY=90:3,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
"RTN","PSODIR1",140,0)
 I '$D(CLOZPAT) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F")!(PSODRUG("DEA")[1)!(PSODRUG("DEA")[2) D  G REFILLX
"RTN","PSODIR1",141,0)
 .I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")[1)!(PSODRUG("DEA")[2)!'$O(^PSRX(+$G(PSODIR("IRXN")),1,0))!('$G(PSOLOKED)) D  Q
"RTN","PSODIR1",142,0)
 ..S VALMSG="No refills allowed on "_$S(PSODRUG("DEA")["F":"this drug.",1:"Narcotics.") W !,VALMSG,!
"RTN","PSODIR1",143,0)
 ..S:$D(PSODIR("FIELD")) PSODIR("FIELD")=0 S PSODIR("# OF REFILLS")=0
"RTN","PSODIR1",144,0)
 ..Q
"RTN","PSODIR1",145,0)
 .;reset refills to the # given
"RTN","PSODIR1",146,0)
 .D RFRSET^PSODIR2
"RTN","PSODIR1",147,0)
 .Q
"RTN","PSODIR1",148,0)
 I $P($G(PSODIR("CS")),"^",2)=1 W !,"No refills allowed on Schedule 2 drugs...",! S:$D(PSODIR("FIELD")) PSODIR("FIELD")=0 S PSODIR("# OF REFILLS")=0 G REFILLX
"RTN","PSODIR1",149,0)
 I $D(CLOZPAT) S PSOX=$S($G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=14):1,$G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=7):3,$G(CLOZPAT)=1&(PSODIR("DAYS SUPPLY")=7):1,1:0)
"RTN","PSODIR1",150,0)
 ;PSO*7*266 make sure PSOX is greater than RFTT
"RTN","PSODIR1",151,0)
 S DIR(0)="N^"_$S($G(RFTT):RFTT,1:0)_":"_$S(+$G(RFTT)>PSOX:RFTT,1:PSOX),DIR("A")="# OF REFILLS"
"RTN","PSODIR1",152,0)
 ;PSO*7*340 Correct Default Value.
"RTN","PSODIR1",153,0)
 S DIR("B")=$S($G(COPY):PSODIR("# OF REFILLS"),$G(PSODIR("N# REF"))]"":PSODIR("N# REF"),$G(PSODIR("# OF REFILLS"))]"":PSODIR("# OF REFILLS"),$G(PSOX1)]""&(PSOX>PSOX1):PSOX1,$G(RFTT)>PSOX:RFTT,1:PSOX)
"RTN","PSODIR1",154,0)
 S DIR("?")="Enter a whole number.  The maximum is set by the DAYS SUPPLY field."
"RTN","PSODIR1",155,0)
 D DIR G:PSODIR("DFLG")!PSODIR("FIELD") REFILLX
"RTN","PSODIR1",156,0)
 S (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=Y
"RTN","PSODIR1",157,0)
REFILLX S:$G(PSODIR("# OF REFILLS"))']"" PSODIR("# OF REFILLS")=$S($G(PSODIR("N# REF"))]"":PSODIR("N# REF"),$G(PSOX1)]""&($G(PSOX)>PSOX1):PSOX1,1:PSOX)
"RTN","PSODIR1",158,0)
 K X,Y,PSOX,PSOX1,PSDY,PSDY1,DEA,PSOCS,RFTT ;PSO*7*340 Kill RFTT
"RTN","PSODIR1",159,0)
 Q
"RTN","PSODIR1",160,0)
 ;OERR CALL
"RTN","PSODIR1",161,0)
REFOR ;
"RTN","PSODIR1",162,0)
 D REFOR^PSODIR3
"RTN","PSODIR1",163,0)
 G REFILLX
"RTN","PSODIR1",164,0)
 Q
"RTN","PSODIR1",165,0)
DIR ;
"RTN","PSODIR1",166,0)
 S (PSODIR("FIELD"),PSODIR("DFLG"))=0
"RTN","PSODIR1",167,0)
 G:$G(DIR(0))']"" DIRX
"RTN","PSODIR1",168,0)
 D ^DIR K DIR,DIE,DIC,DA
"RTN","PSODIR1",169,0)
 I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)),$L($G(X))'>1!(Y="") S PSODIR("DFLG")=1 G DIRX
"RTN","PSODIR1",170,0)
 I $D(DIRUT)!($D(DIROUT)),$G(SPEED) S PSODIR("DFLG")=1 G DIRX
"RTN","PSODIR1",171,0)
 I X[U,$L(X)>1 D JUMP
"RTN","PSODIR1",172,0)
DIRX K DIRUT,DTOUT,DUOUT,DIROUT
"RTN","PSODIR1",173,0)
 Q
"RTN","PSODIR1",174,0)
JUMP ;
"RTN","PSODIR1",175,0)
 I $G(PSOEDIT)!($G(OR0)) S PSODIR("DFLG")=1 Q
"RTN","PSODIR1",176,0)
 S X=$P(X,"^",2),DIC="^DD(52,",DIC(0)="QM" D ^DIC K DIC
"RTN","PSODIR1",177,0)
 I Y=-1 S PSODIR("FIELD")=PSODIR("FLD") G JUMPX
"RTN","PSODIR1",178,0)
 I $G(PSONEW1)=0 D JUMP^PSONEW1 G JUMPX
"RTN","PSODIR1",179,0)
 I $G(PSOREF1)=0 D JUMP^PSOREF1 G JUMPX
"RTN","PSODIR1",180,0)
 I $G(PSONEW3)=0 D JUMP^PSONEW3 G JUMPX
"RTN","PSODIR1",181,0)
 I $G(PSORENW3)=0 D JUMP^PSORENW3 G JUMPX
"RTN","PSODIR1",182,0)
JUMPX S X="^"_X
"RTN","PSODIR1",183,0)
 Q
"RTN","PSODIR1",184,0)
SIGOK ;review and decide on oerr sig
"RTN","PSODIR1",185,0)
 I '$O(SIG(0)) S SIGOK=0 Q
"RTN","PSODIR1",186,0)
 K SIGOK W !,"SIG: "
"RTN","PSODIR1",187,0)
 F SIG=0:0 S SIG=$O(SIG(SIG)) W SIG(SIG)_" ",!?5 Q:'$O(SIG(SIG))
"RTN","PSODIR1",188,0)
 K DIR,DIRUT,DUOUT,DTOUT S DIR("B")="YES",DIR(0)="Y",DIR("A")="Is this SIG correct" D ^DIR K DIR I $D(DIRUT) S PSODIR("DFLG")=1 K DIRUT,DUOUT,DTOUT Q
"RTN","PSODIR1",189,0)
 S SIGOK=Y I Y K PSODIR("SIG")
"RTN","PSODIR1",190,0)
 Q
"RTN","PSODIR1",191,0)
PSTPB ;
"RTN","PSODIR1",192,0)
 W !,"New orders entered through this option must have a Patient Status of 'NON-VA'!",!
"RTN","PSODIR1",193,0)
 Q
"RTN","PSODISP")
0^43^B53119721^B55745559
"RTN","PSODISP",1,0)
PSODISP ;BIR/SAB,PWC - MANUAL BARCODE RELEASE FUNCTION ;03/02/93
"RTN","PSODISP",2,0)
 ;;7.0;OUTPATIENT PHARMACY;**15,71,131,156,185,148,247,200,385,391**;DEC 1997;Build 13
"RTN","PSODISP",3,0)
 ;Reference to $$SERV^IBARX1 supported by DBIA 2245
"RTN","PSODISP",4,0)
 ;Reference to ^PSD(58.8 supported by DBIA 1036
"RTN","PSODISP",5,0)
 ;Reference to ^PS(55 supported by DBIA 2228
"RTN","PSODISP",6,0)
 ;Reference to ^PSDRUG supported by DBIA 221
"RTN","PSODISP",7,0)
 ;Reference to ^PSDRUG("AQ" supported by DBIA 3165
"RTN","PSODISP",8,0)
 ;Reference to ^XTMP("PSA" supported by DBIA 1036
"RTN","PSODISP",9,0)
 ;Reference to ^PS(59.7 supported by DBIA 694
"RTN","PSODISP",10,0)
 ;Reference to ^DIC(19.2 supported by DBIA 1064
"RTN","PSODISP",11,0)
AC K CX,PSODA,PSODT,PSRH,DA,DR,DIE,X,X1,X2,Y,RXP,CX,PX,REC,DIR,YDT,REC,RDUZ,DIRUT,PSOCPN,PSOCPRX,YY,QDRUG,QTY,TYPE,XTYPE,DUOUT,PSOPID
"RTN","PSODISP",12,0)
 K ^UTILITY($J,"PSOHL") S PSOPID=1
"RTN","PSODISP",13,0)
 I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,?5,"Site Parameters must be defined to use the Release option!",! G EXIT
"RTN","PSODISP",14,0)
 S Y=$G(^PS(59,PSOSITE,"IB")),PSOIBSS=$$SERV^IBARX1(+Y) I 'PSOIBSS D IBSSR^PSOUTL I 'PSOIBFL D   G EXIT
"RTN","PSODISP",15,0)
 .W $C(7),!!,"The IB SERVICE/SECTION defined in your site parameter file is not valid.",!,"You will not be able to release any medication until this is corrected!",!
"RTN","PSODISP",16,0)
AC1 W !! S PSIN=+$P($G(^PS(59.7,1,49.99)),"^",2)
"RTN","PSODISP",17,0)
 S DIC("S")="I $D(^XUSEC(""PSORPH"",+Y))",DIC("A")="Enter PHARMACIST: ",DIC="^VA(200,",DIC(0)="QEAM" D ^DIC G:"^"[X EXIT K DIC G:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!(Y=-1) EXIT S PSRH=+Y
"RTN","PSODISP",18,0)
 ;check for Drug Acct background job K8 & K7.1
"RTN","PSODISP",19,0)
 S X="PSA IV ALL LOCATIONS",DIC(0)="MZ",DIC=19.2 D ^DIC I Y=-1 K DIC,X,Y G BC
"RTN","PSODISP",20,0)
 I $P($G(Y(0)),U,2)>DT S PSODA=1 S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT G BC
"RTN","PSODISP",21,0)
 S X="PSA IV ALL LOCATIONS",DIC(0)="MZ",DIC=19 D ^DIC K DIC,X G:Y=-1 BC
"RTN","PSODISP",22,0)
 K DIQ,PSA S DA=+Y,DIC=19,DIQ="PSA",DR=200,DIQ(0)="IN" D EN^DIQ1
"RTN","PSODISP",23,0)
 I '$D(PSA(19,DA,200,"I")) K DIC,DA,X,Y,DIQ G BC
"RTN","PSODISP",24,0)
 I PSA(19,DA,200,"I")>DT S PSODA=1 S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT
"RTN","PSODISP",25,0)
 K PSA,DIC,DA,X,Y,DIQ
"RTN","PSODISP",26,0)
BC ;
"RTN","PSODISP",27,0)
 K MAN I $G(RXP),$D(DISGROUP),$D(BINGNAM),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
"RTN","PSODISP",28,0)
 Q:$G(POERR)  W !! K CMOP,ISUF,DIR,LBL,LBLP S DIR("A")="Enter/Wand PRESCRIPTION number",DIR("?")="^D HELP^PSODISP",DIR(0)="FO" D ^DIR
"RTN","PSODISP",29,0)
 I $D(DIRUT)!($D(DTOUT))!($D(DUOUT)) K DIRUT,DTOUT,DUOUT G AC1
"RTN","PSODISP",30,0)
 I X'["-" D BCI W:'$G(RXP) !,"INVALID PRESCRIPTION NUMBER" G:'$G(RXP) BC S MAN=1 G BC1
"RTN","PSODISP",31,0)
 I X["-",$P(X,"-")'=$P($$SITE^VASITE(),"^",3) W !?7,$C(7),$C(7),"   INVALID STATION NUMBER !!",$C(7),$C(7),! G BC
"RTN","PSODISP",32,0)
 I X["-" S RXP=$P(X,"-",2) I '$D(^PSRX(+$G(RXP),0))!($G(RXP)']"") W !?7,$C(7),$C(7),$C(7),"   NON-EXISTENT PRESCRIPTION" G BC
"RTN","PSODISP",33,0)
 I $D(^PSRX(RXP,0)) D  G BC1
"RTN","PSODISP",34,0)
 .S PSOLOUD=1 D:$P($G(^PS(55,+$P(^PSRX(+RXP,0),"^",2),0)),"^",6)'=2 EN^PSOHLUP($P(^PSRX(+RXP,0),"^",2)) K PSOLOUD
"RTN","PSODISP",35,0)
 W !?7,$C(7),$C(7),$C(7),"   IMPROPER BARCODE FORMAT" G BC
"RTN","PSODISP",36,0)
BC1 ;
"RTN","PSODISP",37,0)
 D ICN^PSODPT(+$P(^PSRX(RXP,0),"^",2))
"RTN","PSODISP",38,0)
 I +$P($G(^PSRX(+RXP,"STA")),"^")=13!(+$P($G(^PSRX(+RXP,0)),"^",2)=0) W !?7,$C(7),$C(7),"    PRESCRIPTION IS A DELETED PRESCRIPTION NUMBER" Q:$G(POERR)  D DCHK G BC
"RTN","PSODISP",39,0)
 I +$P($G(^PSRX(+RXP,"STA")),"^"),$S($P(^("STA"),"^")=2:0,$P(^("STA"),"^")=5:0,$P(^("STA"),"^")=11:0,$P(^("STA"),"^")=12:0,$P(^("STA"),"^")=14:0,$P(^("STA"),"^")=15:0,1:1) D STAT^PSODISPS Q:$G(POERR)  D DCHK G BC
"RTN","PSODISP",40,0)
 ;drug stocked in Drug Acct Location?
"RTN","PSODISP",41,0)
 S PSODA(1)=$S($D(^PSD(58.8,+$O(^PSD(58.8,"AOP",+PSOSITE,0)),1,+$P(^PSRX(RXP,0),U,6))):1,1:0)
"RTN","PSODISP",42,0)
 I $P(^PSRX(RXP,2),"^",13) S Y=$P(^PSRX(RXP,2),"^",13) X ^DD("DD") S OUT=1 D  K OUT Q:$G(POERR)  D DCHK G BC
"RTN","PSODISP",43,0)
 .W !!?7,$C(7),$C(7),$S($G(SPEED):"Rx# "_$P(^PSRX(RXP,0),"^"),1:"Original prescription")_" was last released on "_Y,!?7,"Checking for unreleased refills/partials " D REF
"RTN","PSODISP",44,0)
BATCH ;
"RTN","PSODISP",45,0)
 I $P(^PSRX(RXP,2),"^",15),'$P(^(2),"^",14) S RESK=$P(^(2),"^",15)  W !!?5,"Rx# "_$P(^PSRX(RXP,0),"^")_" Original Fill returned to stock on "_$E(RESK,4,5)_"/"_$E(RESK,6,7)_"/"_$E(RESK,2,3),! G REF
"RTN","PSODISP",46,0)
 ;flag to determine if site is running HL7 v.2.4 Dispense Machines
"RTN","PSODISP",47,0)
 N PSODISP S PSODISP=$$GET1^DIQ(59,PSOSITE_",",105,"I")
"RTN","PSODISP",48,0)
 S PSOCPN=$P(^PSRX(RXP,0),"^",2),QTY=$P($G(^PSRX(RXP,0)),"^",7),QDRUG=$P(^PSRX(RXP,0),"^",6)
"RTN","PSODISP",49,0)
 ;original
"RTN","PSODISP",50,0)
 I '$P($G(^PSRX(RXP,2)),"^",13),+$P($G(^(2)),"^",2)'<PSIN S RXFD=$P(^(2),"^",2) D  D:$G(LBLP) UPDATE I $G(ISUF) D UPDATE G REF
"RTN","PSODISP",51,0)
 .S SUPN=$O(^PS(52.5,"B",RXP,0)) I SUPN,$D(^PS(52.5,"C",RXFD,SUPN)),$G(^PS(52.5,SUPN,"P"))'=1,'$P($G(^(0)),"^",5) S ISUF=1 Q
"RTN","PSODISP",52,0)
 .I $D(^PSDRUG("AQ",QDRUG)) K CMOP D OREL^PSOCMOPB(RXP) K CMOP I $G(ISUF) K ISUF,CMOP Q
"RTN","PSODISP",53,0)
 .;
"RTN","PSODISP",54,0)
 .F LBL=0:0 S LBL=$O(^PSRX(RXP,"L",LBL)) Q:'LBL  I '+$P(^PSRX(RXP,"L",LBL,0),"^",2),'$P(^(0),"^",5),$P(^(0),"^",3)'["INTERACTION" S LBLP=1
"RTN","PSODISP",55,0)
 .D CHKADDR^PSODISPS(RXP)
"RTN","PSODISP",56,0)
 .Q:'$G(LBLP)
"RTN","PSODISP",57,0)
 .;
"RTN","PSODISP",58,0)
 .; - Checking for OPEN/UNRESOLVED 3rd. Party Payer Rejects / NDC Editing
"RTN","PSODISP",59,0)
 .I $$MANREL^PSOBPSUT(RXP,0,$G(PSOPID))="^" K LBLP Q
"RTN","PSODISP",60,0)
 .;
"RTN","PSODISP",61,0)
 .S:$D(^PSDRUG(QDRUG,660.1)) ^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)-QTY
"RTN","PSODISP",62,0)
 .D NOW^%DTC S DIE="^PSRX(",DA=RXP,DR="31///"_%_";23////"_PSRH_";32.1///@;32.2///@",PSODT=% D ^DIE K DIE,DR,DA,LBL
"RTN","PSODISP",63,0)
 .;
"RTN","PSODISP",64,0)
 .; - Notifying IB through ECME of the Rx has been released
"RTN","PSODISP",65,0)
 .D IBSEND^PSOBPSUT(RXP,0)
"RTN","PSODISP",66,0)
 .;
"RTN","PSODISP",67,0)
 .D EN^PSOHLSN1(RXP,"ZD")
"RTN","PSODISP",68,0)
 .;if appropriate update ^XTMP("PSA", for Drug Acct
"RTN","PSODISP",69,0)
 .I $G(PSODA),$G(PSODA(1)),'$D(^PSRX("AR",+PSODT,+RXP,0)) S ^XTMP("PSA",+PSOSITE,+QDRUG,+DT)=$G(^XTMP("PSA",+PSOSITE,+QDRUG,+DT))+QTY
"RTN","PSODISP",70,0)
REF ;release refills and partials
"RTN","PSODISP",71,0)
 K LBLP,IFN F XTYPE=1,"P" K IFN D QTY^PSODISPS
"RTN","PSODISP",72,0)
 Q:+$G(OUT)!($G(POERR))  D DCHK
"RTN","PSODISP",73,0)
 G BC
"RTN","PSODISP",74,0)
UPDATE I $G(ISUF) W $C(7),!!?7,"Prescription "_$P(^PSRX(RXP,0),"^")_" - Original Fill on Suspense !",!,$C(7) Q
"RTN","PSODISP",75,0)
 N BFILL S BFILL=0
"RTN","PSODISP",76,0)
 S PSOCPRX=$P(^PSRX(RXP,0),"^") D CP^PSOCP
"RTN","PSODISP",77,0)
 W !?7,"Prescription Number "_$P(^PSRX(RXP,0),"^")_" Released"
"RTN","PSODISP",78,0)
 I $$STATUS^PSOBPSUT(RXP)]"",$$WINFILL^PSODISPS(RXP) D SIGMSG^PSODISPS
"RTN","PSODISP",79,0)
 ;initialize bingo board variables
"RTN","PSODISP",80,0)
 I $G(LBLP),$P(^PSRX(RXP,0),"^",11)["W" S BINGRO="W",BINGNAM=$P(^PSRX(RXP,0),"^",2),BINGDIV=$P(^PSRX(RXP,2),"^",9)
"RTN","PSODISP",81,0)
 I $G(PSODISP)=2.4 D    ;HL7 v2.4 dispensing machines
"RTN","PSODISP",82,0)
 . F I=0:0 S SUB=$O(^PSRX(RXP,"A",I)) Q:'I  I $P(^PSRX(RXP,"A",I,0),"^",2)="N" D XMIT    ;only send release dt/time transmission for dispensed orders
"RTN","PSODISP",83,0)
 Q
"RTN","PSODISP",84,0)
EXIT ;
"RTN","PSODISP",85,0)
 K OUT,RX2,RXFD,RESK,ISUF,SUPN,%,DIC,IFN,J,DA,DR,DIE,X,X1,X2,Y,RXP,CX,PX,REC,DIR,YDT,REC,RDUZ,DIRUT,PSOCPN,PSOCPRX,PSOIBSS,PSOIBFL,PSOIBLP,PSOIBST,YY,QDRUG,QTY,TYPE,XTYPE,DUOUT,PSRH,XX,Y,PSIN,MAN,PSODISP,SUB
"RTN","PSODISP",86,0)
 Q
"RTN","PSODISP",87,0)
GETFILL ; get the fill number
"RTN","PSODISP",88,0)
 S NFLD=0,UU="" F  S UU=$O(^PSRX(+RXP,1,UU)) Q:UU=""  S:$D(^PSRX(+RXP,1,UU,0)) NFLD=NFLD+1
"RTN","PSODISP",89,0)
 Q
"RTN","PSODISP",90,0)
HELP W !!,"Wand the barcode number of the prescription or manually key in",!,"the number below the barcode or the prescription number.",!,"The barcode number should be of the format - 'NNN-NNNNNNN'"
"RTN","PSODISP",91,0)
 Q
"RTN","PSODISP",92,0)
BCI S RXP=0
"RTN","PSODISP",93,0)
RXP S RXP=$O(^PSRX("B",X,RXP)) I $P($G(^PSRX(+RXP,"STA")),"^")=13 G RXP ;GET RECORD NUMBER FROM SCRIPT NUMBER
"RTN","PSODISP",94,0)
 Q
"RTN","PSODISP",95,0)
DCHK ;checks for duplicate
"RTN","PSODISP",96,0)
 Q:'$G(MAN)
"RTN","PSODISP",97,0)
 I $D(DISGROUP),$D(BINGNAM),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
"RTN","PSODISP",98,0)
 S RXP=$O(^PSRX("B",$P(^PSRX(RXP,0),"^"),RXP)) I 'RXP K POERR,MAN Q
"RTN","PSODISP",99,0)
 I $P($G(^PSRX(RXP,"STA")),"^")=13 G DCHK
"RTN","PSODISP",100,0)
 I $D(DISGROUP),$D(BINGNAM),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
"RTN","PSODISP",101,0)
 W !!,"Duplicate Rx # "_$P(^PSRX(RXP,0),"^")_" found."
"RTN","PSODISP",102,0)
 S POERR=1 D BC1^PSODISP
"RTN","PSODISP",103,0)
 I $D(DISGROUP),$D(BINGNAM),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
"RTN","PSODISP",104,0)
 G DCHK
"RTN","PSODISP",105,0)
 Q
"RTN","PSODISP",106,0)
XMIT D NOW^%DTC S PSODTM=%
"RTN","PSODISP",107,0)
 S IDGN=$P(^PSRX(+RXP,0),"^",6)
"RTN","PSODISP",108,0)
 K ^UTILITY($J,"PSOHL")
"RTN","PSODISP",109,0)
 S ^UTILITY($J,"PSOHL",1)=+RXP_"^"_IDGN_"^"_PSODTM_"^"_+$G(PDUZ)_"^0^^PSO DISP^^^"_FP_"^"_FPN
"RTN","PSODISP",110,0)
 S ZTRTN="INIT^PSORELDT",ZTDESC="EXTERNAL INTERFACE FOR RELEASE DATE/TIME",ZTIO="",ZTDTH=$H,ZTSAVE("^UTILITY($J,""PSOHL"",")="",ZTSAVE("PSOSITE")="",ZTSAVE("RXP")="",ZTSAVE("PSOLAP")="" D ^%ZTLOAD K ^UTILITY($J,"PSOHL")
"RTN","PSODISP",111,0)
 Q
"RTN","PSODISP1")
0^20^B49194938^B43577126
"RTN","PSODISP1",1,0)
PSODISP1 ;BHAM ISC/SAB,PDW - Rx released/unrelease report ;08 Oct 1999  9:58 AM
"RTN","PSODISP1",2,0)
 ;;7.0;OUTPATIENT PHARMACY;**15,9,33,391**;DEC 1997;Build 13
"RTN","PSODISP1",3,0)
 ;External reference to ^PS(59.7 supported by DBIA 694
"RTN","PSODISP1",4,0)
 ;External reference to ^PSDRUG( supported by DBIA 221
"RTN","PSODISP1",5,0)
 I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,"Pharmacy Division must be selected!",! G EXIT
"RTN","PSODISP1",6,0)
AC S (I,MUL)=0,SITE=PSOSITE,PSIN=+$P($G(^PS(59.7,1,49.99)),"^",2)
"RTN","PSODISP1",7,0)
 F  S I=$O(^PS(59,I)) Q:'I  S MUL=MUL+1
"RTN","PSODISP1",8,0)
 W @IOF,!?15,"Report of Released and UnReleased Prescriptions",!
"RTN","PSODISP1",9,0)
 I $G(MUL)>1 D  G:$D(STOP) EXIT
"RTN","PSODISP1",10,0)
 .W ! S DIR("?",1)="Your Site Parameter file shows multiple divisions.",DIR("A",1)="You are currently logged in under the "_$P(^PS(59,PSOSITE,0),"^",1)_" division."
"RTN","PSODISP1",11,0)
 .S DIR("A")="Do you want to select a different division",DIR("?")="Enter 'Y' to select a different division for this report.",DIR(0)="Y",DIR("B")="NO" D ^DIR K DIR S:$D(DIRUT) STOP=1
"RTN","PSODISP1",12,0)
 .I $G(Y)=1 W ! S DIC("A")="Division: ",DIC=59,DIC(0)="AEQM" D ^DIC K DIC I $D(DIRUT) S STOP=1 Q
"RTN","PSODISP1",13,0)
 .Q:Y<1  S SITE=+Y W !
"RTN","PSODISP1",14,0)
 W ! S DIR("B")="NO",DIR("A")="Do you want ONLY Unreleased Prescriptions",DIR("?")="Enter 'Y' for ONLY Unreleased Prescriptions",DIR(0)="Y" D ^DIR K DIR G:$D(DTOUT)!($D(DUOUT)) EXIT S DUD=Y
"RTN","PSODISP1",15,0)
 ;
"RTN","PSODISP1",16,0)
CS ; ask CS selection criteria - store in DUD1
"RTN","PSODISP1",17,0)
 K DIR
"RTN","PSODISP1",18,0)
 S DIR(0)="SA^C:Controlled Substances Rxs Only;N:Non-controlled Substances Rxs Only;B:Both Controlled and Non-controlled Substance Rxs"
"RTN","PSODISP1",19,0)
 S DIR("B")="B",DIR("A")="Include (C)S Rx only, (N)on CS Rx only, or (B)oth (C/N/B): "
"RTN","PSODISP1",20,0)
 K DUD1 D ^DIR K DIR G:$D(DTOUT)!($D(DUOUT)) EXIT
"RTN","PSODISP1",21,0)
 S DUD1=Y
"RTN","PSODISP1",22,0)
 I DUD1="C" D  G:$D(DIRUT) EXIT K DIR,X,Y,I,J,K
"RTN","PSODISP1",23,0)
 .K DIR  W !!,"Select controlled substance schedules"
"RTN","PSODISP1",24,0)
 .S DIR(0)="S^1:SCHEDULES I - II;2:SCHEDULES III - V;3:SCHEDULES I - V",DIR("A")="Select Schedule(s)",DIR("B")=3
"RTN","PSODISP1",25,0)
 .D ^DIR
"RTN","PSODISP1",26,0)
 .I +Y>0 S SCH=Y S I=$S(Y=2:3,1:1),J=$S(Y=1:2,1:5) F K=I:1:J S SCH(K)=""
"RTN","PSODISP1",27,0)
 W ! S %DT(0)=PSIN,X1=DT,X2=-30 D C^%DTC I X>PSIN S (BEGDT,Y)=X
"RTN","PSODISP1",28,0)
 E  S (BEGDT,Y)=PSIN
"RTN","PSODISP1",29,0)
 X ^DD("DD") S BEG=Y,%DT("A")="Enter Start date: ",%DT("B")=BEG,%DT="AEPX",%DT(0)=PSIN D ^%DT G:"^"[$E(X) EXIT S (%DT(0),BEGDT)=Y
"RTN","PSODISP1",30,0)
 S Y=DT X ^DD("DD") S END=Y
"RTN","PSODISP1",31,0)
 S %DT("A")="Ending date: ",%DT("B")=END D ^%DT K %DT G:"^"[$E(X) EXIT S ENDDT=Y
"RTN","PSODISP1",32,0)
 S Y=ENDDT D DD^%DT S PEDATE=Y S Y=BEGDT D DD^%DT S PSDATE=Y
"RTN","PSODISP1",33,0)
 ; ***
"RTN","PSODISP1",34,0)
 K IO("Q"),%ZIS,IOP,ZTSK S PSOION=ION,%ZIS("S")="I $E($G(^%ZIS(2,+$G(^(""SUBTYPE"")),0)),1)=""P""",%ZIS="MQ",%ZIS("A")="Select a PRINTER: ",%ZIS("B")=""
"RTN","PSODISP1",35,0)
 D ^%ZIS I POP S IOP=PSOION D ^%ZIS K IOP,PSOION G EXIT
"RTN","PSODISP1",36,0)
 K PSOION I $D(IO("Q")) D  G EXIT
"RTN","PSODISP1",37,0)
 .S ZTRTN="BC^PSODISP1",ZTDESC="Report of released & unreleased prescriptions",ZTSAVE("SCH(")=""
"RTN","PSODISP1",38,0)
 .F G="BEGDT","ENDDT","PSDATE","PEDATE","SITE","DUD","DUD1","PSXSYS","SCH" S:$D(@G) ZTSAVE(G)=""
"RTN","PSODISP1",39,0)
 .D ^%ZTLOAD W:$D(ZTSK) !,"Report Queued to Print !!",! K ZTSK,IO("Q")
"RTN","PSODISP1",40,0)
 ;
"RTN","PSODISP1",41,0)
BC S PG=1,(REL,UNREL,CP)=0 U IO D HD,RPT
"RTN","PSODISP1",42,0)
 W !!,"# of Released Fills - "_REL_"  # of Unreleased Fills - "_UNREL_"  # of Copay Fills - "_CP
"RTN","PSODISP1",43,0)
 I $E($G(IOST),1,2)'["C-" W !,@IOF
"RTN","PSODISP1",44,0)
EXIT D ^%ZISC K PG,LIN,G,REL,RPT,UNREL,BEG,BEGDT,END,ENDDT,DR,X,X1,X2,Y,REC,DIR,DIRUT,DUOUT,I,Y,RXN,NODE,PAR,BDT,PSX,PSXZ,SCH,CSDEA
"RTN","PSODISP1",45,0)
 K PSOLCMF,STOP,TYPE,UNDERL,ZTDESC,ZTRTN,ZTSAVE,DIC,XY,ND,DUD,DUD1,DTOUT,SITE,MUL,CP,PSIN,%DT,PSDATE,PEDATE S:$D(ZTQUEUED) ZTREQ="@" K ZTQUEUED
"RTN","PSODISP1",46,0)
 Q
"RTN","PSODISP1",47,0)
RPT S ND="",RXN=0,BDT=BEGDT-1 F  S BDT=$O(^PSRX("AD",BDT)) Q:'BDT!(BDT>ENDDT)  F  S RXN=$O(^PSRX("AD",BDT,RXN)) Q:'RXN  F  S ND=$O(^PSRX("AD",BDT,RXN,ND)) Q:ND=""  S NODE=ND D  I $Y+4>IOSL D HD
"RTN","PSODISP1",48,0)
 .Q:$G(^PSRX(RXN,0))']""  I $G(PSXSYS) K PSX D CMOP^PSOCMOPA
"RTN","PSODISP1",49,0)
 .Q:$G(^PSRX(RXN,0))']""  D @$S(NODE:"REF",1:"RPT2") K LB,LBLP
"RTN","PSODISP1",50,0)
 S (RXN,ND)=0,BDT=BEGDT-1 F  S BDT=$O(^PSRX("ADP",BDT)) Q:'BDT!(BDT>ENDDT)  F  S RXN=$O(^PSRX("ADP",BDT,RXN)) Q:'RXN  F  S ND=$O(^PSRX("ADP",BDT,RXN,ND)) Q:'ND  S NODE=ND D  I $Y+4>IOSL D HD
"RTN","PSODISP1",51,0)
 .Q:$G(^PSRX(RXN,0))']""  S PAR=1 D REF K LB,LBLP
"RTN","PSODISP1",52,0)
 Q
"RTN","PSODISP1",53,0)
RPT2 I $P($G(^PSRX(RXN,2)),"^",13),DUD Q
"RTN","PSODISP1",54,0)
 I $P($G(^PSRX(RXN,2)),"^",15)]"",'$P(^(2),"^",14) Q
"RTN","PSODISP1",55,0)
 I $P($G(^PSRX(RXN,2)),"^",9)'=SITE Q
"RTN","PSODISP1",56,0)
 S XY=$P(^PSRX(RXN,"STA"),"^") I (XY=3)!(XY=4)!(XY=13)!(XY=16) Q
"RTN","PSODISP1",57,0)
 S CSDEA=$$CSDEA(RXN) I CSDEA=0 Q  ; quit if CS Criteria fails
"RTN","PSODISP1",58,0)
 I $P(^PSRX(RXN,2),"^",13) W !,$P(^PSRX(RXN,0),"^"),?16,$E($$GET1^DIQ(50,$P(^PSRX(RXN,0),"^",6),.01),1,30),?48,"0" S Y=$P(^PSRX(RXN,2),"^",13) W ?52,$P($$FMTE^XLFDT(Y,"2Z"),"@"),?62,$$SCH($P(CSDEA,"^",2)) S REL=REL+1 D CP1 Q
"RTN","PSODISP1",59,0)
 I '$P(^PSRX(RXN,2),"^",13) D  Q:('$G(LBLP)&($G(PSX(0))']""))  W !,$P(^PSRX(RXN,0),"^"),?16,$E($$GET1^DIQ(50,$P(^PSRX(RXN,0),"^",6),.01),1,30),?48,"0",?62,$$SCH($P(CSDEA,"^",2)) S UNREL=UNREL+1 D CP1
"RTN","PSODISP1",60,0)
 .F LB=0:0 S LB=$O(^PSRX(RXN,"L",LB)) Q:'LB  I '$P(^PSRX(RXN,"L",LB,0),"^",2),$P(^(0),"^",3)'["INTERACTION",'$P(^(0),"^",5) S LBLP=1 Q
"RTN","PSODISP1",61,0)
 Q
"RTN","PSODISP1",62,0)
REF ;
"RTN","PSODISP1",63,0)
 I $P($G(^PSRX(RXN,$S('$G(PAR):1,1:"P"),NODE,0)),"^",$S('$G(PAR):18,1:19)),DUD Q
"RTN","PSODISP1",64,0)
 I $P($G(^PSRX(RXN,$S('$G(PAR):1,1:"P"),NODE,0)),"^",9)'=SITE Q
"RTN","PSODISP1",65,0)
 I $P($G(^PSRX(RXN,$S('$G(PAR):1,1:"P"),NODE,0)),"^",16)]"" Q
"RTN","PSODISP1",66,0)
 S XY=$P(^PSRX(RXN,"STA"),"^") I (XY=3)!(XY=4)!(XY>12) Q
"RTN","PSODISP1",67,0)
 S CSDEA=$$CSDEA(RXN) I CSDEA=0 Q  ; quit if CS Criteria fails
"RTN","PSODISP1",68,0)
 I $P($G(^PSRX(RXN,$S('$G(PAR):1,1:"P"),NODE,0)),"^",$S('$G(PAR):18,1:19)) D  G CP1
"RTN","PSODISP1",69,0)
 .W !,$P(^PSRX(RXN,0),"^"),?16,$E($$GET1^DIQ(50,$P(^PSRX(RXN,0),"^",6),.01),1,30),?48,$S('$G(PAR):"",1:"P"),NODE S REL=REL+1
"RTN","PSODISP1",70,0)
 .S Y=$P(^PSRX(RXN,$S('$G(PAR):1,1:"P"),NODE,0),"^",$S('$G(PAR):18,1:19)) W ?52,$P($$FMTE^XLFDT(Y,"2Z"),"@"),?62,$$SCH($P(CSDEA,"^",2))
"RTN","PSODISP1",71,0)
 I '$P(^PSRX(RXN,$S('$G(PAR):1,1:"P"),NODE,0),"^",$S('$G(PAR):18,1:19)) S RPT=0 D  Q:'RPT
"RTN","PSODISP1",72,0)
 .F LB=0:0 S LB=$O(^PSRX(RXN,"L",LB)) Q:'LB  I $P(^PSRX(RXN,"L",LB,0),"^",2)=$S('$G(PAR):NODE,1:99-NODE) S LBLP=1 Q
"RTN","PSODISP1",73,0)
 .Q:('$G(LBLP)&($G(PSX(NODE))']""))
"RTN","PSODISP1",74,0)
 .D TEST Q:'$G(LBLP)&($G(PSOLCMF))
"RTN","PSODISP1",75,0)
 .S RPT=1 W !,$P(^PSRX(RXN,0),"^"),?16,$E($$GET1^DIQ(50,$P(^PSRX(RXN,0),"^",6),.01),1,30),?48,$S('$G(PAR):"",1:"P"),NODE,?62,$$SCH($P(CSDEA,"^",2)) S UNREL=UNREL+1
"RTN","PSODISP1",76,0)
CP1 W ?68,$S(XY=1:"NV",XY=2:"Ref",XY=3!(XY=16):"HLD",XY=5:"SUSP",XY=10:"DONE",XY=11:"EXP",XY=12!(XY=14)!(XY=15):"DC",1:"ACT")
"RTN","PSODISP1",77,0)
 Q:$G(PAR)  I $P($G(^PSRX(RXN,"IB")),"^") W ?77,"Y" S CP=CP+1
"RTN","PSODISP1",78,0)
 I $G(PSX(NODE))]"" W ?85,"Y",?95,$S(PSX(NODE)=0:"Transmitted",PSX(NODE)=1:"Dispensed",PSX(NODE)=2:"Retransmitted",PSX(NODE)=3:"Not Dispensed",1:"Unknown")
"RTN","PSODISP1",79,0)
 Q
"RTN","PSODISP1",80,0)
 ;
"RTN","PSODISP1",81,0)
HD W @IOF,?$S('DUD:17,1:20),$S('DUD:"Release/",1:"")_"Unreleased Report for "_$P(^PS(59,SITE,0),"^",1),!
"RTN","PSODISP1",82,0)
 I $G(DUD1)="N" W ?13,"Non-controlled Substance Prescriptions Only"
"RTN","PSODISP1",83,0)
 I $G(DUD1)="C" W ?8,"Controlled Substance Prescriptions (",$S(SCH=1:"Schedules I - II",SCH=2:"Schedules III - V",SCH=3:"Schedules I - V",1:"")_")"
"RTN","PSODISP1",84,0)
 W !?18,PSDATE_" to "_PEDATE,?70,"Page: "_PG,!!,?47,"Fill/",?54,"Date",!,"Rx #",?16,"Drug",?47,"Ref#",?54,"Rel",?62,"Sch",?67,"Status",?75,"Copay     " W:$G(PSXSYS) "CMOP      CMOP Status" W ! F LIN=1:1:$S($G(PSXSYS):115,1:80) W "-"
"RTN","PSODISP1",85,0)
 W ! S PG=PG+1 Q
"RTN","PSODISP1",86,0)
 ;
"RTN","PSODISP1",87,0)
TEST ;
"RTN","PSODISP1",88,0)
 S (PSOLCMF,PSOLCMR)=0
"RTN","PSODISP1",89,0)
 F PSOLCR=0:0 S PSOLCR=$O(^PSRX(RXN,1,PSOLCR)) Q:'PSOLCR  I $D(^(PSOLCR,0)) S PSOLCMR=PSOLCR
"RTN","PSODISP1",90,0)
 I '$G(PSOLCMR) G TESTX
"RTN","PSODISP1",91,0)
 F PSOLCR=0:0 S PSOLCR=$O(^PSRX(RXN,"A",PSOLCR)) Q:'PSOLCR!($G(PSOLCMF))  D
"RTN","PSODISP1",92,0)
 .Q:$P($G(^PSRX(RXN,"A",PSOLCR,0)),"^",2)'="I"
"RTN","PSODISP1",93,0)
 .I $G(PSOLCMR)<6 S:$P($G(^PSRX(RXN,"A",PSOLCR,0)),"^",4)=$G(PSOLCMR) PSOLCMF=1 Q
"RTN","PSODISP1",94,0)
 .S PSOLCMRZ=$G(PSOLCMR)+1 S:PSOLCMRZ=$P($G(^PSRX(RXN,"A",PSOLCR,0)),"^",4) PSOLCMF=1 K PSOLCMRZ Q
"RTN","PSODISP1",95,0)
TESTX K PSOLCR,PSOLCMR
"RTN","PSODISP1",96,0)
 Q
"RTN","PSODISP1",97,0)
CSDEA(X) ;CS Criteria .. returns a 1 if both DEA on drug & criteria 'N/C/B' are satisfied
"RTN","PSODISP1",98,0)
 N DEA,DRUGDA
"RTN","PSODISP1",99,0)
 S DRUGDA=$$GET1^DIQ(52,X,6,"I"),DEA=$$GET1^DIQ(50,DRUGDA,3)
"RTN","PSODISP1",100,0)
 I DUD1="B" Q 1_"^"_+DEA ;both CS & non CS (all) 
"RTN","PSODISP1",101,0)
 ;CS
"RTN","PSODISP1",102,0)
 I DUD1="C" Q $S('+DEA:0,'$D(SCH(+DEA)):0,1:1_"^"_+DEA)
"RTN","PSODISP1",103,0)
 ;Non CS
"RTN","PSODISP1",104,0)
 I (+DEA<1)!(+DEA>5) Q 1_"^"_+DEA
"RTN","PSODISP1",105,0)
 Q 0
"RTN","PSODISP1",106,0)
 ;
"RTN","PSODISP1",107,0)
SCH(X) ;Schedule conversion
"RTN","PSODISP1",108,0)
 Q:+X<1 ""
"RTN","PSODISP1",109,0)
 Q $P("I^II^III^IV^V","^",X)
"RTN","PSOHLEXP")
0^19^B22400492^B14786719
"RTN","PSOHLEXP",1,0)
PSOHLEXP ;BIR/RTR-Auto expire prescriptions ; 10/10/07 11:16am
"RTN","PSOHLEXP",2,0)
 ;;7.0;OUTPATIENT PHARMACY;**10,22,36,73,148,257,391**;DEC 1997;Build 13
"RTN","PSOHLEXP",3,0)
 ;
"RTN","PSOHLEXP",4,0)
 ;External reference to ^PS(59.7 supported by DBIA 694
"RTN","PSOHLEXP",5,0)
 ;External reference to STATUS^ORQOR2 is supported by DBIA 3458
"RTN","PSOHLEXP",6,0)
 ;External references to LOCK1^ORX2 and UNLK1^ORX2 are supported by DBIA 867
"RTN","PSOHLEXP",7,0)
EN N PSOEXRX,PSOEXCOM,PSOEXSTS,SUSD,PSOEXSTA,ZZDT,ZZEDT,IFN,NODE,RF,PIFN,PSUSD,PRFDT,PDA,PSDTEST,ORN,CPRSDC
"RTN","PSOHLEXP",8,0)
 I '$G(DT) S DT=$$DT^XLFDT
"RTN","PSOHLEXP",9,0)
 S X1=DT,X2=-1 D C^%DTC S ZZEDT=X
"RTN","PSOHLEXP",10,0)
 S ZZDT=$P($G(^PS(59.7,1,49.99)),"^",8) I +ZZDT=0 S X1=DT,X2=-2 D C^%DTC S ZZDT=X
"RTN","PSOHLEXP",11,0)
 F  S ZZDT=$O(^PSRX("AG",ZZDT)) Q:ZZDT>ZZEDT  Q:ZZDT=""  D EN1
"RTN","PSOHLEXP",12,0)
 D FACDEA
"RTN","PSOHLEXP",13,0)
 Q
"RTN","PSOHLEXP",14,0)
EN1 F PSOEXRX=0:0 S PSOEXRX=$O(^PSRX("AG",ZZDT,PSOEXRX)) Q:'PSOEXRX  D:$D(^PSRX(PSOEXRX,0))
"RTN","PSOHLEXP",15,0)
 .N CPRSDC,CPRSSTA
"RTN","PSOHLEXP",16,0)
 .S CPRSDC=",1,7,12,13,"
"RTN","PSOHLEXP",17,0)
 .S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2),CPRSSTA=""
"RTN","PSOHLEXP",18,0)
 .I ORN S CPRSSTA=+$$STATUS^ORQOR2(ORN) I CPRSSTA=0 S ORN=""
"RTN","PSOHLEXP",19,0)
 .Q:$P($G(^PSRX(PSOEXRX,2)),"^",6)'=ZZDT
"RTN","PSOHLEXP",20,0)
 .K CMOP S DA=PSOEXRX I DA D ^PSOCMOPA  ;*257 ;SET UP CMOP() ARRAY
"RTN","PSOHLEXP",21,0)
 .S DA=$O(^PS(52.5,"B",PSOEXRX,0))
"RTN","PSOHLEXP",22,0)
 .I DA S SUSD=$P($G(^PS(52.5,DA,0)),"^",2) I SUSD,$P($G(^(0)),"^",3) S DIK="^PS(52.5," D ^DIK K DIK
"RTN","PSOHLEXP",23,0)
 .I $D(^PS(52.4,PSOEXRX,0)) S DIK="^PS(52.4,",DA=PSOEXRX D ^DIK K DIK
"RTN","PSOHLEXP",24,0)
 .I $G(^PSRX(PSOEXRX,"H"))]"" K:$P(^PSRX(PSOEXRX,"H"),"^") ^PSRX("AH",$P(^PSRX(PSOEXRX,"H"),"^"),PSOEXRX) S ^PSRX(PSOEXRX,"H")=""
"RTN","PSOHLEXP",25,0)
 .S PSOEXSTA=$P($G(^PSRX(PSOEXRX,"STA")),"^")
"RTN","PSOHLEXP",26,0)
 .I PSOEXSTA=13 D  Q
"RTN","PSOHLEXP",27,0)
 ..I 'ORN D EN^PSOHDR("PRES",PSOEXRX)
"RTN","PSOHLEXP",28,0)
 .I PSOEXSTA=12!(PSOEXSTA=14)!(PSOEXSTA=15) I ORN,CPRSDC'[(","_CPRSSTA_",") D
"RTN","PSOHLEXP",29,0)
 ..D EN^PSOHLSN1(PSOEXRX,"OD","","","A")
"RTN","PSOHLEXP",30,0)
 ..I ORN S CPRSSTA=+$$STATUS^ORQOR2(ORN)
"RTN","PSOHLEXP",31,0)
 .I PSOEXSTA=11 I ORN,CPRSDC'[(","_CPRSSTA_",") D
"RTN","PSOHLEXP",32,0)
 ..S $P(^PSRX(PSOEXRX,0),"^",19)=1
"RTN","PSOHLEXP",33,0)
 ..D EN^PSOHLSN1(PSOEXRX,"SC","ZE","Prescription is expired")
"RTN","PSOHLEXP",34,0)
 .I PSOEXSTA>9&(PSOEXSTA'=16) Q
"RTN","PSOHLEXP",35,0)
 .S $P(^PSRX(PSOEXRX,"STA"),"^")=11
"RTN","PSOHLEXP",36,0)
 .D REVERSE^PSOBPSU1(PSOEXRX,0,"DE",5,"RX EXPIRED")
"RTN","PSOHLEXP",37,0)
 .S (PIFN,PSUSD,PRFDT)=0 F  S PIFN=$O(^PSRX(PSOEXRX,1,PIFN)) Q:'PIFN  S PSUSD=PIFN,PRFDT=+$P($G(^PSRX(PSOEXRX,1,PIFN,0)),"^")
"RTN","PSOHLEXP",38,0)
 .S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2)
"RTN","PSOHLEXP",39,0)
 .I $G(PSUSD) I '$P($G(^PSRX(PSOEXRX,1,PSUSD,0)),"^",18) S PSDTEST=0 D  I 'PSDTEST K ^PSRX(PSOEXRX,1,PSUSD),^PSRX("AD",PRFDT,PSOEXRX,PSUSD),^PSRX(PSOEXRX,1,"B",PRFDT,PSUSD) D NSET
"RTN","PSOHLEXP",40,0)
 ..D REVERSE^PSOBPSU1(PSOEXRX,PSUSD,"DE",5,"RX EXPIRED")
"RTN","PSOHLEXP",41,0)
 ..F PDA=0:0 S PDA=$O(^PSRX(PSOEXRX,"L",PDA)) Q:'PDA  I $P($G(^PSRX(PSOEXRX,"L",PDA,0)),"^",2)=PSUSD S PSDTEST=1
"RTN","PSOHLEXP",42,0)
 ..I $G(CMOP(CMOP("L")))="",".L.X."[("."_$G(CMOP("S"))_".") S PSDTEST=1
"RTN","PSOHLEXP",43,0)
 ..N PSOORL
"RTN","PSOHLEXP",44,0)
 ..S PSOORL=$$LOCK1^ORX2(ORN) S:'PSOORL PSDTEST=1 I PSOORL D UNLK1^ORX2(ORN)
"RTN","PSOHLEXP",45,0)
 ..N PDA0
"RTN","PSOHLEXP",46,0)
 ..;S PDAQ=0
"RTN","PSOHLEXP",47,0)
 ..F PDA=0:0 S PDA=$O(^PSRX(PSOEXRX,4,PDA)) Q:'PDA  D
"RTN","PSOHLEXP",48,0)
 ...S PDA0=$G(^PSRX(PSOEXRX,4,PDA,0))
"RTN","PSOHLEXP",49,0)
 ...I $P(PDA0,"^",3)=PSUSD S PSDTEST=1   ;*257
"RTN","PSOHLEXP",50,0)
 ..;Q:'PDAQ
"RTN","PSOHLEXP",51,0)
 ..;S PSDTEST=1
"RTN","PSOHLEXP",52,0)
 .I 'ORN D EN^PSOHDR("PRES",PSOEXRX) Q
"RTN","PSOHLEXP",53,0)
 .I CPRSDC[(","_CPRSSTA_",") D EN^PSOHDR("PRES",PSOEXRX) Q
"RTN","PSOHLEXP",54,0)
 .S $P(^PSRX(PSOEXRX,0),"^",19)=1
"RTN","PSOHLEXP",55,0)
 .S PSOEXCOM="Prescription past expiration date" D EN^PSOHLSN1(PSOEXRX,"SC","ZE",PSOEXCOM)
"RTN","PSOHLEXP",56,0)
 S DIE=59.7,DA=1,DR="49.95///"_ZZDT D ^DIE K DIE,DA,DR
"RTN","PSOHLEXP",57,0)
 Q
"RTN","PSOHLEXP",58,0)
NSET ;
"RTN","PSOHLEXP",59,0)
 N PSONM,PSONMX
"RTN","PSOHLEXP",60,0)
 S PSONM="" F PSONMX=0:0 S PSONMX=$O(^PSRX(PSOEXRX,1,PSONMX)) Q:'PSONMX  S PSONM=PSONMX
"RTN","PSOHLEXP",61,0)
 S ^PSRX(PSOEXRX,1,0)="^52.1DA^"_$G(PSONM)_"^"_$G(PSONM)
"RTN","PSOHLEXP",62,0)
 Q
"RTN","PSOHLEXP",63,0)
SETUP ;
"RTN","PSOHLEXP",64,0)
 K %DT,DIC,DTOUT S DIC(0)="XZM",DIC="^DIC(19.2,",X="PSO EXPIRE PRESCRIPTIONS" D ^DIC
"RTN","PSOHLEXP",65,0)
 I +Y>0 D EDIT^XUTMOPT("PSO EXPIRE PRESCRIPTIONS") K DIC,Y,X Q
"RTN","PSOHLEXP",66,0)
 D RESCH^XUTMOPT("PSO EXPIRE PRESCRIPTIONS","","","24H","L"),EDIT^XUTMOPT("PSO EXPIRE PRESCRIPTIONS") K DIC,Y,X
"RTN","PSOHLEXP",67,0)
OUT Q
"RTN","PSOHLEXP",68,0)
FACDEA ;PSO*7*391/JAM  - Checks and notifies PSDMGR group when facility DEA is about to expire.
"RTN","PSOHLEXP",69,0)
 N DIV,INACT,SITE,DEA,DEAXDT,XMDUZ,XMY,XMTEXT,XMSUB,USR,TEXT
"RTN","PSOHLEXP",70,0)
 S DIV=0 F  S DIV=$O(^PS(59,DIV)) Q:'DIV  D
"RTN","PSOHLEXP",71,0)
 .S INACT=$P($G(^PS(59,DIV,"I")),"^") I INACT,DT>INACT Q
"RTN","PSOHLEXP",72,0)
 .S SITE=$P($G(^PS(59,DIV,"INI")),"^") I SITE="" Q
"RTN","PSOHLEXP",73,0)
 .I '$$ACTIVE^XUAF4(SITE) Q
"RTN","PSOHLEXP",74,0)
 .S DEA=$$WHAT^XUAF4(SITE,52) I DEA="" Q
"RTN","PSOHLEXP",75,0)
 .S DEAXDT=$$GET1^DIQ(4,SITE,52.1,"I") I '+DEAXDT Q
"RTN","PSOHLEXP",76,0)
 .I $$FMDIFF^XLFDT(DEAXDT,DT)>30 Q
"RTN","PSOHLEXP",77,0)
 .S DIV(SITE)=DEA_"^"_DEAXDT
"RTN","PSOHLEXP",78,0)
 S SITE=0 F  S SITE=$O(DIV(SITE)) Q:'SITE  D
"RTN","PSOHLEXP",79,0)
 .K TEXT
"RTN","PSOHLEXP",80,0)
 .S DEAXDT=$P(DIV(SITE),"^",2)
"RTN","PSOHLEXP",81,0)
 .S TEXT(1)="",TEXT(2)="Please update Institutional DEA Certification Date. "_$S($$FMDIFF^XLFDT(DEAXDT,DT)<0:"Expired on ",1:"Will expire on ")_$$FMTE^XLFDT(DEAXDT,2)_".",TEXT(3)=""
"RTN","PSOHLEXP",82,0)
 .S XMTEXT="TEXT(",XMSUB=SITE_":Institutional DEA Expiration Date "_$S($$FMDIFF^XLFDT(DEAXDT,DT)<0:"has expired",1:"is about to expire"),XMDUZ=.5
"RTN","PSOHLEXP",83,0)
 .S USR="" F  S USR=$O(^XUSEC("PSDMGR",USR)) Q:USR=""  S XMY(USR)=""
"RTN","PSOHLEXP",84,0)
 .D ^XMD
"RTN","PSOHLEXP",85,0)
 Q
"RTN","PSOHLNE1")
0^40^B74363469^B73330251
"RTN","PSOHLNE1",1,0)
PSOHLNE1 ;BIR/RTR-Parsing out segments from OERR ;01/20/95
"RTN","PSOHLNE1",2,0)
 ;;7.0;OUTPATIENT PHARMACY;**1,9,46,71,98,111,117,131,157,181,143,235,239,225,391**;DEC 1997;Build 13
"RTN","PSOHLNE1",3,0)
 ;External reference to EN^ORERR supported by DBIA 2187
"RTN","PSOHLNE1",4,0)
 ;External reference to PS(50.607 supported by DBIA 2221
"RTN","PSOHLNE1",5,0)
 ;External reference to OR(100 supported by DBIA 2219
"RTN","PSOHLNE1",6,0)
 ;External reference to PSDRUG( supported by DBIA 221
"RTN","PSOHLNE1",7,0)
 ;External reference VADPT supported by DBIA 10061
"RTN","PSOHLNE1",8,0)
 ;
"RTN","PSOHLNE1",9,0)
EN ;ORC segment
"RTN","PSOHLNE1",10,0)
 N Q1,Q2,Q3,Q4,Q5,Q6,Q7,PSOPOSSD
"RTN","PSOHLNE1",11,0)
 K PSOLQ1I,PSOLQ1II,PSOLQ1IX
"RTN","PSOHLNE1",12,0)
 I '$O(MSG(ZZ,0)) D
"RTN","PSOHLNE1",13,0)
 .S PSOOC="NW",PLACER=+$P(PSOSEG,"|",2),PLACERXX=+$P($P(PSOSEG,"|",2),";",2),ENTERED=$P(PSOSEG,"|",10),PROV=$P(PSOSEG,"|",12)
"RTN","PSOHLNE1",14,0)
 .S X=$P(PSOSEG,"|",15) S EFFECT=$$HL7TFM^XLFDT(X) K X
"RTN","PSOHLNE1",15,0)
 .D NOW^%DTC S PSOLOG=% K %
"RTN","PSOHLNE1",16,0)
 .;S RSN=$P(PSOSEG,"|",16)
"RTN","PSOHLNE1",17,0)
 .S ORCSEG=$P(PSOSEG,"|",7),QCOUNT=1 Q:$G(ORCSEG)'["~"
"RTN","PSOHLNE1",18,0)
 .F JJ=1:1:$L(ORCSEG) S:$E(ORCSEG,JJ)="~" QCOUNT=QCOUNT+1
"RTN","PSOHLNE1",19,0)
 I '$O(MSG(ZZ,0)) D  Q
"RTN","PSOHLNE1",20,0)
 .F JJJ=1:1:QCOUNT S QQQ=$P(ORCSEG,"~",JJJ) D:QQQ'=""
"RTN","PSOHLNE1",21,0)
 ..S PSOPOSSD=$S($P($P(QQQ,"^"),"&"):1,1:0) ;PSOPOSSD=1 if possible dose
"RTN","PSOHLNE1",22,0)
 ..S Q9(JJJ)=$P(QQQ,"^")
"RTN","PSOHLNE1",23,0)
 ..S Q1I(JJJ)=$S(PSOPOSSD:$P(QQQ,"^"),1:$P(QQQ,"^",8)),PSOLQ1IX(JJJ)=$P($P(QQQ,"^"),"&",5) S PSOLQ1I(JJJ)=$P(QQQ,"^",8),PSOLQ1II(JJJ)=PSOPOSSD ;ORC piece 1 if Possible Dosage, ORC piece 8 if Local Possible Dosage
"RTN","PSOHLNE1",24,0)
 ..S Q1(JJJ)=$P(QQQ,"^",2) ;schedule
"RTN","PSOHLNE1",25,0)
 ..S Q2(JJJ)=$P(QQQ,"^",3) ;duration
"RTN","PSOHLNE1",26,0)
 ..S Q3(JJJ)=$P(QQQ,"^",4) I Q3(JJJ) S X=Q3(JJJ) S Q3(JJJ)=$$HL7TFM^XLFDT(X) K X ;start date
"RTN","PSOHLNE1",27,0)
 ..S Q4(JJJ)=$P(QQQ,"^",5) ;end date
"RTN","PSOHLNE1",28,0)
 ..S:$G(PRIOR)="" PRIOR=$P(QQQ,"^",6)
"RTN","PSOHLNE1",29,0)
 ..S Q6(JJJ)=$P(QQQ,"^",9) ;conjunction
"RTN","PSOHLNE1",30,0)
 ..S Q7(JJJ)=$P(QQQ,"^",10) ;sequencing
"RTN","PSOHLNE1",31,0)
 ..S QTARRAY(JJJ)=Q1(JJJ)_"^"_Q2(JJJ)_"^"_Q3(JJJ)_"^"_Q4(JJJ)_"^^"_Q6(JJJ)_"^"_Q7(JJJ)
"RTN","PSOHLNE1",32,0)
 ..S QTARRAY2(JJJ)=$S(PSOPOSSD:$P(Q1I(JJJ),"&"),1:Q1I(JJJ))_"^"_$S(PSOPOSSD:$P(Q1I(JJJ),"&",3),1:"")
"RTN","PSOHLNE1",33,0)
 ..I PSOPOSSD S $P(QTARRAY(JJJ),"^",5)=$P(Q1I(JJJ),"&",4)
"RTN","PSOHLNE1",34,0)
 ..I PSOPOSSD S PSOUNN=$P(Q1I(JJJ),"&",2) I PSOUNN'="" S PSOUNN=$O(^PS(50.607,"B",PSOUNN,0)) S $P(QTARRAY(JJJ),"^",9)=$G(PSOUNN)
"RTN","PSOHLNE1",35,0)
 ..K PSOUNN
"RTN","PSOHLNE1",36,0)
 ;For multiple ORC subscripts
"RTN","PSOHLNE1",37,0)
 S (POVAR,POVAR1)="",(NNCK,NNN,NNNN)=0,PSOIII=1,MSG(ZZ,0)=$E(MSG(ZZ),5,$L(MSG(ZZ)))
"RTN","PSOHLNE1",38,0)
 S AAA="" F  S AAA=$O(MSG(ZZ,AAA)) Q:AAA=""  S NNN=0 F OOO=1:1:$L(MSG(ZZ,AAA)) S NNN=NNN+1 D  D:$G(POVAR1)="~"&(NNNN=6) PARSE D:$G(POVAR1)="|" PARSE
"RTN","PSOHLNE1",39,0)
 .I $E(MSG(ZZ,AAA),OOO)="|" S NNNN=NNNN+1
"RTN","PSOHLNE1",40,0)
 .S POVAR1=$E(MSG(ZZ,AAA),OOO)
"RTN","PSOHLNE1",41,0)
 .S POLIM=POVAR
"RTN","PSOHLNE1",42,0)
 .S POVAR=$S(POVAR="":POVAR1,1:POVAR_POVAR1)
"RTN","PSOHLNE1",43,0)
 .;I NNNN=6 I $G(POVAR1)="~"!($G(POVAR1)="|")
"RTN","PSOHLNE1",44,0)
END ;16 OF ORC?
"RTN","PSOHLNE1",45,0)
 ;I $G(POVAR)'="" I NNNN=14!(NNNN=15) S EFFECT=$G(POVAR)
"RTN","PSOHLNE1",46,0)
 S QCOUNT=0 F JJJ=0:0 S JJJ=$O(QTVAR(JJJ)) Q:'JJJ  I $L($G(QTVAR(JJJ))) S QCOUNT=QCOUNT+1 D
"RTN","PSOHLNE1",47,0)
 .S PSOPOSSD=$S($P($P(QTVAR(JJJ),"^"),"&"):1,1:0) ;PSOPOSSD =1 if possible dose
"RTN","PSOHLNE1",48,0)
 .S Q1I(JJJ)=$S(PSOPOSSD:$P(QTVAR(JJJ),"^"),1:$P(QTVAR(JJJ),"^",8)),PSOLQ1IX(JJJ)=$P($P(QTVAR(JJJ),"^"),"&",5) S PSOLQ1I(JJJ)=$P(QTVAR(JJJ),"^",8),PSOLQ1II(JJJ)=PSOPOSSD ;piece 1 if possible dose, piece 8 if not
"RTN","PSOHLNE1",49,0)
 .S Q9(JJJ)=$P(QTVAR(JJJ),"^")
"RTN","PSOHLNE1",50,0)
 .S Q1(JJJ)=$P(QTVAR(JJJ),"^",2)
"RTN","PSOHLNE1",51,0)
 .S Q2(JJJ)=$P(QTVAR(JJJ),"^",3)
"RTN","PSOHLNE1",52,0)
 .;S Q2(JJJ)=$S($E($P(QTVAR(JJJ),"^",3)):"D"_$P(QTVAR(JJJ),"^",3),$E($P(QTVAR(JJJ),"^",3))=0:"D"_$P(QTVAR(JJJ),"^",3),1:$P(QTVAR(JJJ),"^",3))
"RTN","PSOHLNE1",53,0)
 .S Q3(JJJ)=$P(QTVAR(JJJ),"^",4) I Q3(JJJ) S X=Q3(JJJ) S Q3(JJJ)=$$HL7TFM^XLFDT(X) K X
"RTN","PSOHLNE1",54,0)
 .S Q4(JJJ)=$P(QTVAR(JJJ),"^",5)
"RTN","PSOHLNE1",55,0)
 .S:$G(PRIOR)="" PRIOR=$P(QTVAR(JJJ),"^",6)
"RTN","PSOHLNE1",56,0)
 .S Q6(JJJ)=$P(QTVAR(JJJ),"^",9)
"RTN","PSOHLNE1",57,0)
 .S Q7(JJJ)=$P(QTVAR(JJJ),"^",10)
"RTN","PSOHLNE1",58,0)
 .S QTARRAY(JJJ)=Q1(JJJ)_"^"_Q2(JJJ)_"^"_Q3(JJJ)_"^"_Q4(JJJ)_"^^"_Q6(JJJ)_"^"_Q7(JJJ)
"RTN","PSOHLNE1",59,0)
 .S QTARRAY2(JJJ)=$S(PSOPOSSD:$P(Q1I(JJJ),"&"),1:Q1I(JJJ))_"^"_$S(PSOPOSSD:$P(Q1I(JJJ),"&",3),1:"")
"RTN","PSOHLNE1",60,0)
 .I PSOPOSSD S $P(QTARRAY(JJJ),"^",5)=$P(Q1I(JJJ),"&",4)
"RTN","PSOHLNE1",61,0)
 .I PSOPOSSD S PSOUNN=$P(Q1I(JJJ),"&",2) I PSOUNN'="" S PSOUNN=$O(^PS(50.607,"B",PSOUNN,0)) S $P(QTARRAY(JJJ),"^",9)=$G(PSOUNN)
"RTN","PSOHLNE1",62,0)
 .K PSOUNN
"RTN","PSOHLNE1",63,0)
 I $G(EFFECT) S X=EFFECT S EFFECT=$$HL7TFM^XLFDT(X) K X
"RTN","PSOHLNE1",64,0)
 D NOW^%DTC S PSOLOG=% S:'$G(EFFECT) EFFECT=% K %
"RTN","PSOHLNE1",65,0)
 K MSG(ZZ,0)
"RTN","PSOHLNE1",66,0)
 Q
"RTN","PSOHLNE1",67,0)
PARSE I NNNN=1 S PSOOC="NW" G SET
"RTN","PSOHLNE1",68,0)
 I NNNN=2 S PLACER=+$G(POLIM),PLACERXX=+$P($G(POLIM),";",2) G SET
"RTN","PSOHLNE1",69,0)
 I NNNN=3!(NNNN=4)!(NNNN=5) G SET
"RTN","PSOHLNE1",70,0)
 I NNNN=6,$G(POVAR1)="~" S NNCK=NNCK+1,QTVAR(NNCK)=$G(POLIM) G SET
"RTN","PSOHLNE1",71,0)
 I NNNN=7 S NNCK=NNCK+1 S QTVAR(NNCK)=$G(POLIM) G SET
"RTN","PSOHLNE1",72,0)
 I NNNN=8!(NNNN=9) G SET
"RTN","PSOHLNE1",73,0)
 I NNNN=10 S ENTERED=$G(POLIM) G SET
"RTN","PSOHLNE1",74,0)
 I NNNN=11 G SET
"RTN","PSOHLNE1",75,0)
 I NNNN=12 S PROV=$G(POLIM) G SET
"RTN","PSOHLNE1",76,0)
 I NNNN=13!(NNNN=14) G SET
"RTN","PSOHLNE1",77,0)
 I NNNN=15 S EFFECT=$G(POLIM)
"RTN","PSOHLNE1",78,0)
SET S (POVAR,POLIM)="" Q
"RTN","PSOHLNE1",79,0)
 ;
"RTN","PSOHLNE1",80,0)
EXP ;
"RTN","PSOHLNE1",81,0)
 ;Q:'$G(OR("PLACE"))
"RTN","PSOHLNE1",82,0)
 Q:'$G(PSOFILNM)
"RTN","PSOHLNE1",83,0)
 S PSOMSORR=1
"RTN","PSOHLNE1",84,0)
 N PSOSSMES S PSOSSMES="CPRSUP"
"RTN","PSOHLNE1",85,0)
 I $G(PSOFILNM),$G(PSOFILNM)["S" S LL=+$G(PSOFILNM) I $D(^PS(52.41,LL,0)),$P($G(^(0)),"^",3)'="RF" G EXPEN
"RTN","PSOHLNE1",86,0)
 S LL=$G(PSOFILNM) I 'LL!('$D(^PSRX(+$G(LL),0))) S COMM="Order was not located by Pharmacy" D EN^ORERR(COMM,.MSG) D  G EXPQ
"RTN","PSOHLNE1",87,0)
 .F EER=0:0 S EER=$O(MSG(EER)) Q:'EER  S:$P(MSG(EER),"|")="PV1" PSERRPV1=MSG(EER) S:$P(MSG(EER),"|")="PID" PSERRPID=MSG(EER) S:$P(MSG(EER),"|")="ORC"&($G(PSERRORC)="") PSERRORC=MSG(EER)
"RTN","PSOHLNE1",88,0)
 .N MSG,PSOHINST D INIT^PSOHLSN S MSG(2)=$G(PSERRPID),MSG(3)=$G(PSERRPV1),MSG(4)="ORC|DE|"_$G(OR("PLACE"))_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR"_"|"_$S($P($G(PSERRORC),"|",4)'="":$P(PSERRORC,"|",4),1:"") S:$G(COMM)'="" MSG(5)="NTE|16||"_COMM
"RTN","PSOHLNE1",89,0)
 .D SEND^PSOHLSN
"RTN","PSOHLNE1",90,0)
 Q:'$D(^PSRX(LL,0))
"RTN","PSOHLNE1",91,0)
 I +$P($G(^PSRX(LL,2)),"^",6)<DT D
"RTN","PSOHLNE1",92,0)
 .;Reset PSOSSMES if status changes, so HDR gets updated in PSOHLSN1
"RTN","PSOHLNE1",93,0)
 .I +$P($G(^PSRX(LL,"STA")),"^")<12!($P($G(^("STA")),"^")=16) S $P(^PSRX(LL,"STA"),"^")=11 D ECAN^PSOUTL(LL) S PSOSSMES="CPRSVDEF"
"RTN","PSOHLNE1",94,0)
 S GG=+$P($G(^PSRX(LL,"STA")),"^")
"RTN","PSOHLNE1",95,0)
 ;S AA=$S(GG=3:"OH",GG=12:"OD",GG=13:"OC",GG=14:"OD",GG=15:"OD",GG=16:"OH",1:"SC"),AAA=$S(GG=0:"CM",GG=1:"IP",GG=4:"IP",GG=5:"ZS",GG=11:"ZE",1:"")
"RTN","PSOHLNE1",96,0)
 S AA="SC",AAA=$S(GG=0:"CM",GG=2:"CM",GG=1:"IP",GG=4:"IP",GG=5:"ZS",GG=3:"HD",GG=16:"HD",GG=11:"ZE",1:"DC")
"RTN","PSOHLNE1",97,0)
 D EN^PSOHLSN1(LL,AA,AAA,"")
"RTN","PSOHLNE1",98,0)
 K PSOSSMES
"RTN","PSOHLNE1",99,0)
EXPQ K LL,GG,AA,AAA,PSOMSORR Q
"RTN","PSOHLNE1",100,0)
EXPEN ;SS on Pending orders
"RTN","PSOHLNE1",101,0)
 S AA=$P($G(^PS(52.41,LL,0)),"^",3)
"RTN","PSOHLNE1",102,0)
 S AAA=$S(AA="DC"!(AA="DE"):"DC",AA="HD":"HD",1:"IP")
"RTN","PSOHLNE1",103,0)
 D EN^PSOHLSN(OR("PLACE"),"SC",AAA)
"RTN","PSOHLNE1",104,0)
 G EXPQ
"RTN","PSOHLNE1",105,0)
 ;
"RTN","PSOHLNE1",106,0)
OID ;Check for 1 to 1 match from Dispense Drug to Orderable Item
"RTN","PSOHLNE1",107,0)
 N PSOCDD,PSOCDDI,PSOCDDIZ
"RTN","PSOHLNE1",108,0)
 Q:'$G(PSORDITE)
"RTN","PSOHLNE1",109,0)
 K PSOCDDIZ
"RTN","PSOHLNE1",110,0)
 S (PSOCDD,PSOCDDI)=0
"RTN","PSOHLNE1",111,0)
 F  S PSOCDD=$O(^PSDRUG("ASP",PSORDITE,PSOCDD)) Q:'PSOCDD  I $S('$P($G(^PSDRUG(PSOCDD,"I")),"^"):1,DT'>$P($G(^("I")),"^"):1,1:0),$P($G(^PSDRUG(PSOCDD,2)),"^",3)["O" S PSOCDDI=PSOCDDI+1,PSOCDDIZ=PSOCDD
"RTN","PSOHLNE1",112,0)
 I PSOCDDI'=1 Q
"RTN","PSOHLNE1",113,0)
 S PSOQWX=$G(PSOCDDIZ)
"RTN","PSOHLNE1",114,0)
 Q
"RTN","PSOHLNE1",115,0)
CP ;ZSC segment (replaced by ZCL segment)
"RTN","PSOHLNE1",116,0)
 S SERV=$S($P(PSOSEG,"|")=1:"SC",$P(PSOSEG,"|")=0:"NSC",1:$P(PSOSEG,"|"))
"RTN","PSOHLNE1",117,0)
 S PSOIBY=$P(PSOSEG,"|",2)_"^"_$P(PSOSEG,"|",3)_"^"_$P(PSOSEG,"|",4)_"^"_$P(PSOSEG,"|",5)_"^"_$P(PSOSEG,"|",6)_"^"_$P(PSOSEG,"|",7)_"^"_$P(PSOSEG,"|",8)
"RTN","PSOHLNE1",118,0)
 Q
"RTN","PSOHLNE1",119,0)
 ;
"RTN","PSOHLNE1",120,0)
ZCL ;ZCL segment - SC/EI related to ICDs
"RTN","PSOHLNE1",121,0)
 N SEQ,SEQ2,SEQ3 S SEQ3=$P(PSOSEG,"|",2),SEQ2=$P(PSOSEG,"|",1)
"RTN","PSOHLNE1",122,0)
 S:'$D(PSOICD(SEQ2)) PSOICD(SEQ2)=""
"RTN","PSOHLNE1",123,0)
 S $P(PSOICD(SEQ2),"^",(SEQ3+1))=$P(PSOSEG,"|",3)  ;set sc/ei for ICD node
"RTN","PSOHLNE1",124,0)
 D SCP^PSORN52D K PSOSCA
"RTN","PSOHLNE1",125,0)
 S:'$D(PSOIBY) PSOIBY=""
"RTN","PSOHLNE1",126,0)
 I PSOSCP<50 D  ;set IBQ node variables if <50% SC
"RTN","PSOHLNE1",127,0)
 . Q:$P(PSOIBY,U,$S(SEQ3=1:2,SEQ3=2:3,SEQ3=4:4,SEQ3=5:1,SEQ3=6:5,SEQ3=7:6,SEQ3=8:7,1:""))>0
"RTN","PSOHLNE1",128,0)
 . S:SEQ3=1 $P(PSOIBY,U,2)=$P(PSOSEG,"|",3) ;AO
"RTN","PSOHLNE1",129,0)
 . S:SEQ3=2 $P(PSOIBY,U,3)=$P(PSOSEG,"|",3) ;IR
"RTN","PSOHLNE1",130,0)
 . S:SEQ3=3 SERV=$S($P(PSOSEG,"|",3)=1:"SC",$P(PSOSEG,"|",3)=0:"NSC",1:$P(PSOSEG,"|",3))           ;SC
"RTN","PSOHLNE1",131,0)
 . S:SEQ3=4 $P(PSOIBY,U,4)=$P(PSOSEG,"|",3) ;EC
"RTN","PSOHLNE1",132,0)
 . S:SEQ3=5 $P(PSOIBY,U,1)=$P(PSOSEG,"|",3) ;MST
"RTN","PSOHLNE1",133,0)
 . S:SEQ3=6 $P(PSOIBY,U,5)=$P(PSOSEG,"|",3) ;HNC
"RTN","PSOHLNE1",134,0)
 . S:SEQ3=7 $P(PSOIBY,U,6)=$P(PSOSEG,"|",3) ;CV
"RTN","PSOHLNE1",135,0)
 . S:SEQ3=8 $P(PSOIBY,U,7)=$P(PSOSEG,"|",3) ;SHAD
"RTN","PSOHLNE1",136,0)
 Q
"RTN","PSOHLNE1",137,0)
MISX ;Mismatch patient on CPRS New Order
"RTN","PSOHLNE1",138,0)
 S RCOMM="Patient mismatch on New Order from CPRS." D EN^ORERR(RCOMM,.MSG) S NWFLAG=1 D RERROR^PSOHLSN D KL^PSOHLSIH
"RTN","PSOHLNE1",139,0)
 Q
"RTN","PSOHLNE1",140,0)
MISRN ;Mismatch on CPRS renewal
"RTN","PSOHLNE1",141,0)
 N PSOCINV
"RTN","PSOHLNE1",142,0)
 I $G(PDFN)'=$P($G(^PSRX(+$G(PREV),0)),"^",2) D  S PSOMO=1 Q
"RTN","PSOHLNE1",143,0)
 .S RCOMM="Patient mismatch on CPRS Renewal." D EN^ORERR(RCOMM,.MSG) S PSOXRP=1 D RERROR^PSOHLSN D KL^PSOHLSIH
"RTN","PSOHLNE1",144,0)
 S PSOCINV=+$P($G(^OR(100,+$G(PLACER),3)),"^",5)
"RTN","PSOHLNE1",145,0)
 I PSOCINV'=$P($G(^PSRX(+$G(PREV),"OR1")),"^",2) D  S PSOMO=1 Q
"RTN","PSOHLNE1",146,0)
 .S RCOMM="Order mismatch on CPRS Renewal." D EN^ORERR(RCOMM,.MSG) S PSOCVI=1 D RERROR^PSOHLSN D KL^PSOHLSIH
"RTN","PSOHLNE1",147,0)
 Q
"RTN","PSOHLNE1",148,0)
ZRX ;Process ZRX segment
"RTN","PSOHLNE1",149,0)
 I $P(PSOSEG,"|",3)="R" S PSOOC="RNW",PSRNFLAG=1
"RTN","PSOHLNE1",150,0)
 S PREV=$S(+$P(PSOSEG,"|"):+$P(PSOSEG,"|"),1:"")
"RTN","PSOHLNE1",151,0)
 I $P(PSOSEG,"|")["P"!($P(PSOSEG,"|")["S") S PFLAG=1
"RTN","PSOHLNE1",152,0)
 S NATURE=$P(PSOSEG,"|",2)
"RTN","PSOHLNE1",153,0)
 S PSORSO=$P(PSOSEG,"|",3)
"RTN","PSOHLNE1",154,0)
 S ROUTING=$P(PSOSEG,"|",4)
"RTN","PSOHLNE1",155,0)
 I ROUTING="" S ROUTING="M"
"RTN","PSOHLNE1",156,0)
 I $P(PSOSEG,"|",7) S DSIG=1
"RTN","PSOHLNE1",157,0)
 Q
"RTN","PSOHLNE1",158,0)
CHCS ;Replace CHCS number with CPRS number in .01 field
"RTN","PSOHLNE1",159,0)
 N PSOHTMP
"RTN","PSOHLNE1",160,0)
 I $G(PDFN),PDFN'=+$P($G(^PS(52.41,+$G(PSOCHFFL),0)),"^",2) S COMM="Patient does not match" D EN^ORERR(COMM,.MSG) K PSOPLC,PSOFFL,PSOSND Q
"RTN","PSOHLNE1",161,0)
 I '$D(^PS(52.41,+$G(PSOCHFFL),0)) S COMM="Order was not located by Pharmacy" D EN^ORERR(COMM,.MSG) K PSOPLC,PSOFFL,PSOSND Q
"RTN","PSOHLNE1",162,0)
 S PSOHTMP=$P($G(^PS(52.41,+$G(PSOCHFFL),0)),"^")
"RTN","PSOHLNE1",163,0)
 I PSOHTMP'="" K ^PS(52.41,"B",PSOHTMP,+$G(PSOCHFFL))
"RTN","PSOHLNE1",164,0)
 S $P(^PS(52.41,+$G(PSOCHFFL),0),"^")=PSOPLC,^PS(52.41,"B",PSOPLC,+$G(PSOCHFFL))=""
"RTN","PSOHLNE1",165,0)
 S $P(^PS(52.41,+$G(PSOCHFFL),"EXT"),"^",2)=1
"RTN","PSOHLNE1",166,0)
 Q
"RTN","PSOHLNE1",167,0)
CNT ;
"RTN","PSOHLNE1",168,0)
 S TAC=0 F TACA=0:0 S TACA=$O(^PSRX(PREV,"A",TACA)) Q:'TACA  S TAC=TACA
"RTN","PSOHLNE1",169,0)
 S PAC=0 F PACA=0:0 S PACA=$O(^PSRX(PREV,1,PACA)) Q:'PACA  S PAC=PACA
"RTN","PSOHLNE1",170,0)
 D NOW^%DTC S TAC=TAC+1,^PSRX(PREV,"A",0)="^52.3DA^"_TAC_"^"_TAC,^PSRX(PREV,"A",TAC,0)=%_"^"_"C"_"^"_$S(+$G(PROV):$G(PROV),1:+$G(ENTERED))_"^"_PAC_"^"_"Discontinued due to CPRS edit"
"RTN","PSOHLNE1",171,0)
 K TAC,PAC,TACA,PACA
"RTN","PSOHLNE1",172,0)
 Q
"RTN","PSOHLNE1",173,0)
NTE ;
"RTN","PSOHLNE1",174,0)
 S WPCT=1,WORDP=$S($P(MSG(LL),"|",2):$P(MSG(LL),"|",2),1:$P(MSG(LL),"|",3)) S:$P(MSG(LL),"|",4)'="" WPARRAY(WORDP,WPCT)=$P(MSG(LL),"|",4) S:$P(MSG(LL),"|",4)'="" WPCT=WPCT+1 F LLL=0:0 S LLL=$O(MSG(LL,LLL)) Q:'LLL  D
"RTN","PSOHLNE1",175,0)
 .I $G(MSG(LL,LLL))'="" S WPARRAY(WORDP,WPCT)=$G(MSG(LL,LLL)),WPCT=WPCT+1
"RTN","PSOHLNE1",176,0)
 Q
"RTN","PSOHLNE2")
0^41^B64216422^B64195087
"RTN","PSOHLNE2",1,0)
PSOHLNE2 ;BIR/RTR-Parsing out more OERR segments ;8/13/08 2:43pm
"RTN","PSOHLNE2",2,0)
 ;;7.0;OUTPATIENT PHARMACY;**1,7,59,46,225,305,391**;DEC 1997;Build 13
"RTN","PSOHLNE2",3,0)
 ;External reference to DG(40.8 supported by DBIA 728
"RTN","PSOHLNE2",4,0)
 ;External reference to PS(50.606 supported by DBIA 2174
"RTN","PSOHLNE2",5,0)
 ;External reference to PS(50.7 supported by DBIA 2223
"RTN","PSOHLNE2",6,0)
 ;External reference to PSDRUG( supported by DBIA 221
"RTN","PSOHLNE2",7,0)
 ;External reference to PS(55 supported by DBIA 2228
"RTN","PSOHLNE2",8,0)
 ;External reference to SC( supported by DBIA 2675
"RTN","PSOHLNE2",9,0)
 ;External reference to EN^ORERR supported by DBIA 2187
"RTN","PSOHLNE2",10,0)
 ;
"RTN","PSOHLNE2",11,0)
EN ;RXO segment on new orders with multiple subscripts
"RTN","PSOHLNE2",12,0)
 S (POVAR,POVAR1)="",(NNN,NNNN)=0,PSOIII=1,MSG(ZZ,0)=$E(MSG(ZZ),5,$L(MSG(ZZ)))
"RTN","PSOHLNE2",13,0)
 S AAA="" F  S AAA=$O(MSG(ZZ,AAA)) Q:AAA=""  S NNN=0 F OOO=1:1:$L(MSG(ZZ,AAA)) S NNN=NNN+1 D  D:$G(POVAR1)="|" PARSE
"RTN","PSOHLNE2",14,0)
 .I $E(MSG(ZZ,AAA),OOO)="|" S NNNN=NNNN+1
"RTN","PSOHLNE2",15,0)
 .S POVAR1=$E(MSG(ZZ,AAA),OOO)
"RTN","PSOHLNE2",16,0)
 .S POLIM=POVAR
"RTN","PSOHLNE2",17,0)
 .S POVAR=$S(POVAR="":POVAR1,1:POVAR_POVAR1)
"RTN","PSOHLNE2",18,0)
 I $G(POVAR)'="" I NNNN=13!(NNNN=12) S PSOREFIL=POVAR
"RTN","PSOHLNE2",19,0)
 K MSG(ZZ,0)
"RTN","PSOHLNE2",20,0)
 Q
"RTN","PSOHLNE2",21,0)
PARSE ;
"RTN","PSOHLNE2",22,0)
 I NNNN=1 S PSORDITE=$P(POLIM,"^",4) G SET
"RTN","PSOHLNE2",23,0)
 I NNNN=10 S PSODDRUG=$P(POLIM,"^",4) I $G(PSODDRUG),('$D(^PSDRUG(PSODDRUG,0))) S PSODDRUG="" G SET
"RTN","PSOHLNE2",24,0)
 I NNNN=10 S DDR=1 G SET
"RTN","PSOHLNE2",25,0)
 I NNNN=11 S PSOXQTY=POLIM G SET
"RTN","PSOHLNE2",26,0)
 I NNNN=13 S PSOREFIL=POLIM G SET
"RTN","PSOHLNE2",27,0)
 I NNNN=17 S PSODYSPL=POLIM
"RTN","PSOHLNE2",28,0)
SET S (POVAR,POLIM)="" Q
"RTN","PSOHLNE2",29,0)
 ;
"RTN","PSOHLNE2",30,0)
OBXX ;Parse out OBX segments
"RTN","PSOHLNE2",31,0)
 S OCOUNT=OCOUNT+1
"RTN","PSOHLNE2",32,0)
 S (POVAR,POVAR)="",(NNCK,NNN,NNNN)=0,PSOIII=1,MSG(ZZ,0)=$E(MSG(ZZ),5,$L(MSG(ZZ)))
"RTN","PSOHLNE2",33,0)
 S AAA="" F  S AAA=$O(MSG(ZZ,AAA)) Q:AAA=""  S NNN=0 F OOO=1:1:$L(MSG(ZZ,AAA)) S NNN=NNN+1 D  D:$G(POVAR1)="&"&(NNNN=4) OPARSE D:$G(POVAR1)="|" OPARSE
"RTN","PSOHLNE2",34,0)
 .I $E(MSG(ZZ,AAA),OOO)="|" S NNNN=NNNN+1
"RTN","PSOHLNE2",35,0)
 .S POVAR1=$E(MSG(ZZ,AAA),OOO)
"RTN","PSOHLNE2",36,0)
 .S POLIM=POVAR
"RTN","PSOHLNE2",37,0)
 .S POVAR=$S(POVAR="":POVAR1,1:POVAR_POVAR1)
"RTN","PSOHLNE2",38,0)
 I $G(POVAR)'="" I NNNN=4!(NNNN=5) S NNCK=NNCK+1 S OBXAR(OCOUNT,NNCK)=POVAR
"RTN","PSOHLNE2",39,0)
 K MSG(ZZ,0)
"RTN","PSOHLNE2",40,0)
 F OOO=2:1 Q:'$D(OBXAR(OCOUNT,OOO))  S OBXAR(OCOUNT,1)=OBXAR(OCOUNT,1)_"&"_OBXAR(OCOUNT,OOO) K OBXAR(OCOUNT,OOO)
"RTN","PSOHLNE2",41,0)
 Q
"RTN","PSOHLNE2",42,0)
OPARSE ;
"RTN","PSOHLNE2",43,0)
 I NNNN=4,$G(POVAR1)="&" S NNCK=NNCK+1,OBXAR(OCOUNT,NNCK)=$G(POLIM) G OSET
"RTN","PSOHLNE2",44,0)
 I NNNN=5 S NNCK=NNCK+1 S OBXAR(OCOUNT,NNCK)=$G(POLIM)
"RTN","PSOHLNE2",45,0)
OSET S (POVAR,POLIM)="" Q
"RTN","PSOHLNE2",46,0)
 ;
"RTN","PSOHLNE2",47,0)
PURGE ;Purge order initiated by CPRS
"RTN","PSOHLNE2",48,0)
 N DA,PREER,PRG,PPG,PND,PRGFLAG,PURGCOMM,PEER,PURGPV1,PURGPID,PURGORC,PURGRX,PURGPLC,PRGSTAT,PSCC,PSARC,PSCA,PSACOUNT,PURGEXRX,PLAST,PURGLTH,PURGNODE
"RTN","PSOHLNE2",49,0)
 S PSOMSORR=1
"RTN","PSOHLNE2",50,0)
 S PRGFLAG=0
"RTN","PSOHLNE2",51,0)
 I $G(PSOFILNM),$G(PSOFILNM)'["S" S PURGRX=PSOFILNM G PRX
"RTN","PSOHLNE2",52,0)
 S PND=+$G(PSOFILNM) I PND D  G PDNO
"RTN","PSOHLNE2",53,0)
 .I '$D(^PS(52.41,PND,0)) Q
"RTN","PSOHLNE2",54,0)
 .I $G(PDFN),$G(PDFN)'=$P($G(^PS(52.41,PND,0)),"^",2) S PURGCOMM="Patient does not match" D PDERR Q
"RTN","PSOHLNE2",55,0)
 .S PRGSTAT=$P($G(^PS(52.41,PND,0)),"^",3) I PRGSTAT="NW"!(PRGSTAT="RNW")!(PRGSTAT="HD") S PRGFLAG=1 Q
"RTN","PSOHLNE2",56,0)
 .K DIK S DA=PND,DIK="^PS(52.41," D ^DIK K DIK Q
"RTN","PSOHLNE2",57,0)
 S PURGCOMM="Order was not located by Pharmacy."
"RTN","PSOHLNE2",58,0)
 D PDERR G PDNO
"RTN","PSOHLNE2",59,0)
PDERR D EN^ORERR(PURGCOMM,.MSG)
"RTN","PSOHLNE2",60,0)
 Q
"RTN","PSOHLNE2",61,0)
PDNO F PEER=0:0 S PEER=$O(MSG(PEER)) Q:'PEER  S:$P(MSG(PEER),"|")="PV1" PURGPV1=MSG(PEER) S:$P(MSG(PEER),"|")="PID" PURGPID=MSG(PEER) S:$P(MSG(PEER),"|")="ORC"&($G(PURGORC)="") PURGORC=MSG(PEER)
"RTN","PSOHLNE2",62,0)
 N MSG,PSOHINST D INIT^PSOHLSN S MSG(2)=$G(PURGPID),MSG(3)=$G(PURGPV1),MSG(4)="ORC|"_$S($G(PRGFLAG):"ZU",1:"ZR")_"|"_$G(OR("PLACE"))_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR"_"|"_$S($P($G(PURGORC),"|",4)'="":$P(PURGORC,"|",4),1:"")
"RTN","PSOHLNE2",63,0)
 F PREER=11,13 I $P($G(PURGORC),"|",PREER)'="" S $P(MSG(4),"|",PREER)=$P($G(PURGORC),"|",PREER)
"RTN","PSOHLNE2",64,0)
 S $P(MSG(4),"|",17)="^^^^"_$S($G(PRGFLAG):"Unable to Purge order.",1:"OK to Purge order.")_"^"
"RTN","PSOHLNE2",65,0)
 D SEND^PSOHLSN
"RTN","PSOHLNE2",66,0)
PURGEX K PSOMSORR Q
"RTN","PSOHLNE2",67,0)
PRX ;Purge from PSRX here
"RTN","PSOHLNE2",68,0)
 I '$D(^PSRX(PURGRX,0)) G PDNO
"RTN","PSOHLNE2",69,0)
 I $G(PDFN),$G(PDFN)'=$P($G(^PSRX(PURGRX,0)),"^",2) S PURGCOMM="Patient does not match" D PDERR G PDNO
"RTN","PSOHLNE2",70,0)
 I '$P($G(^PSRX(PURGRX,"ARC")),"^") S PRGFLAG=1 G PDNO
"RTN","PSOHLNE2",71,0)
 ;purge from PSRX
"RTN","PSOHLNE2",72,0)
 S PURGEXRX=$P(^PSRX(PURGRX,0),"^")
"RTN","PSOHLNE2",73,0)
 S PSOSUSPA=1 K DIK S DA=PURGRX,PSCC=$P($G(^PSRX(PURGRX,0)),"^",2),DIK="^PSRX(" D ^DIK K DIK,PSOSUSPA
"RTN","PSOHLNE2",74,0)
 I $D(^PS(55,+$G(PSCC),0)) S DA(1)=PSCC,DIK="^PS(55,"_DA(1)_",""P""," F PSCA=0:0 S PSCA=$O(^PS(55,+$G(PSCC),"P",PSCA)) Q:'PSCA  I ^PS(55,+$G(PSCC),"P",PSCA,0)=PURGRX S DA=PSCA D ^DIK K DA,DIK
"RTN","PSOHLNE2",75,0)
 I $D(^PS(52.4,PURGRX,0)) S DA=PURGRX,DIK="^PS(52.4," D ^DIK K DA,DIK
"RTN","PSOHLNE2",76,0)
 S DA=$O(^PS(52.5,"B",PURGRX,"")) I DA S DIK="^PS(52.5," D ^DIK K DIK,DA
"RTN","PSOHLNE2",77,0)
 I '$G(DT) S DT=$$DT^XLFDT
"RTN","PSOHLNE2",78,0)
 I '$G(PSCC) G PUQUIT
"RTN","PSOHLNE2",79,0)
 I '$D(^PS(55,PSCC,"ARC",DT)) S DA=PSCC,DIE=55,DR="101///"_DT,DR(2,55.13)="1///"_$G(PURGEXRX) D ^DIE K DIE G PUQUIT
"RTN","PSOHLNE2",80,0)
 S PLAST=0 F PSARC=0:0 S PSARC=$O(^PS(55,PSCC,"ARC",DT,1,PSARC)) Q:'PSARC  S PLAST=PSARC
"RTN","PSOHLNE2",81,0)
 I $G(PLAST),$D(^PS(55,PSCC,"ARC",DT,1,PLAST,0)) S PURGNODE=^PS(55,PSCC,"ARC",DT,1,PLAST,0) S PURGLTH=$L(PURGNODE) I $G(PURGLTH),PURGLTH<220 S ^PS(55,PSCC,"ARC",DT,1,PLAST,0)=PURGNODE_$S($E(PURGNODE,PURGLTH)'="*":"*",1:"")_PURGEXRX G PUQUIT
"RTN","PSOHLNE2",82,0)
 S DA=PSCC,DIE=55,DR="101///"_DT,DR(2,55.13)="1///"_$G(PURGEXRX) D ^DIE K DIE
"RTN","PSOHLNE2",83,0)
PUQUIT G PDNO
"RTN","PSOHLNE2",84,0)
 ;
"RTN","PSOHLNE2",85,0)
REF ;  Refill request from CPRS
"RTN","PSOHLNE2",86,0)
 N PSORXFL,PSORFX,REFXXX,REFCOM,REFCOMXX,REFEER,REFPV1,REFPID,REFORC,RREER,RFLOOP,REFSEG,RFTYPE,REFILLER,REFVR,PSOERR,PSODUZ,PSOAUTOF
"RTN","PSOHLNE2",87,0)
 I $G(PSOFILNM),$G(PSOFILNM)'["S" S PSORXFL=PSOFILNM G REFRX
"RTN","PSOHLNE2",88,0)
 I $G(PSOFILNM) S PSORFX=+$G(PSOFILNM) D  S REFXXX=1 G REFSND
"RTN","PSOHLNE2",89,0)
 .I '$D(^PS(52.41,PSORFX,0)) S (REFCOMXX,REFCOM)="Order was not located by Pharmacy." D REFERR Q
"RTN","PSOHLNE2",90,0)
 .I $G(PDFN),$G(PDFN)'=$P($G(^PS(52.41,PSORFX,0)),"^",2) S (REFCOMXX,REFCOM)="Patient does not match." D REFERR Q
"RTN","PSOHLNE2",91,0)
 .I $P($G(^PS(52.41,PSORFX,0)),"^",3)="RF" S REFCOM="Refill has already been requested." Q
"RTN","PSOHLNE2",92,0)
 .S REFCOM="Refill request not allowed on Pending order."
"RTN","PSOHLNE2",93,0)
 S (REFCOMXX,REFCOM)="Order was not located by Pharmacy." D REFERR S REFXXX=1 G REFSND
"RTN","PSOHLNE2",94,0)
REFERR D EN^ORERR(REFCOMXX,.MSG)
"RTN","PSOHLNE2",95,0)
 Q
"RTN","PSOHLNE2",96,0)
REFSND ;  Add code here if response message is ever required
"RTN","PSOHLNE2",97,0)
 Q
"RTN","PSOHLNE2",98,0)
REFRX ;
"RTN","PSOHLNE2",99,0)
 I $O(^PS(52.41,"ARF",PSORXFL,0)) S REFXXX=1,REFCOM="Refill request already exists." G REFSND
"RTN","PSOHLNE2",100,0)
 I '$D(^PSRX(PSORXFL,0)) S (REFCOMXX,REFCOM)="Order was not located by Pharmacy." D REFERR S REFXXX=1 G REFSND
"RTN","PSOHLNE2",101,0)
 I $G(PDFN),$G(PDFN)'=$P($G(^PSRX(PSORXFL,0)),"^",2) S (REFCOMXX,REFCOM)="Patient does not match." D REFERR S REFXXX=1 G REFSND
"RTN","PSOHLNE2",102,0)
 F RFLOOP=0:0 S RFLOOP=$O(MSG(RFLOOP)) Q:'RFLOOP  S REFSEG=$G(MSG(RFLOOP)),RFTYPE=$P(REFSEG,"|")_"Z" S REFSEG=$E(REFSEG,5,$L(REFSEG)) I RFTYPE="PIDZ"!(RFTYPE="PV1Z")!(RFTYPE="ORCZ")!(RFTYPE="ZRXZ") D @RFTYPE
"RTN","PSOHLNE2",103,0)
 I '$G(PLACER) S REFXXX=1,REFCOM="Unable to process refill request." G REFSND
"RTN","PSOHLNE2",104,0)
 I $G(REFILLER),$G(REFILLER)'=$G(PSORXFL) S REFCOMXX="Filler number mismatch" D REFERR S REFXXX=1,REFCOM="Unable to process refill request." G REFSND
"RTN","PSOHLNE2",105,0)
 ;
"RTN","PSOHLNE2",106,0)
 ;  Auto Refill, file to Prescription file #52, if key exists and at
"RTN","PSOHLNE2",107,0)
 ;   least one key holder and if CPRS Automated refill flag is on.
"RTN","PSOHLNE2",108,0)
 S PSOAUTOF=0
"RTN","PSOHLNE2",109,0)
 I $D(^XUSEC("PSOAUTRF")),$O(^XUSEC("PSOAUTRF",0)),$$GET1^DIQ(59.7,1,40.16,"I") D
"RTN","PSOHLNE2",110,0)
 . S PSOERR=""
"RTN","PSOHLNE2",111,0)
 . D REF^PSOATRFC(PSOFILNM,.PSOERR)
"RTN","PSOHLNE2",112,0)
 . D:$D(PSOERR)>1 MAILMSG^PSOATRFC($G(PDFN),PSOFILNM,.PSOERR)
"RTN","PSOHLNE2",113,0)
 . ;  If no error msg array, then refill was filed in the Prescription
"RTN","PSOHLNE2",114,0)
 . ;   file #52 so quit, Else file refill to Pending file #52.41
"RTN","PSOHLNE2",115,0)
 . S:$D(PSOERR)<2 PSOAUTOF=1
"RTN","PSOHLNE2",116,0)
 Q:PSOAUTOF
"RTN","PSOHLNE2",117,0)
 ;
"RTN","PSOHLNE2",118,0)
 ;  Manual Refill, file to Pending Outpatient Orders file #52.41
"RTN","PSOHLNE2",119,0)
 K DD,DO S DIC="^PS(52.41,",DIC(0)="L",X=PLACER,DIC("DR")="1////"_$G(DFN)_";2////"_"RF"_";4////"_$G(ENTERED)_";5////"_$G(PROV) D FILE^DICN K DIC,DR I Y<0 S REFXXX=1,REFCOM="Unable to process refill request." G REFSND
"RTN","PSOHLNE2",120,0)
 S PENDING=+Y S $P(^PS(52.41,PENDING,0),"^",13)=$G(LOCATION),$P(^(0),"^",17)=$S($G(ROUTING)'="":$G(ROUTING),1:"W"),$P(^(0),"^",19)=$G(PSORXFL),$P(^(0),"^",20)="F",$P(^(0),"^",14)="R"
"RTN","PSOHLNE2",121,0)
 S $P(^PS(52.41,PENDING,0),"^",8)=$P($G(^PSRX(PSORXFL,"OR1")),"^"),$P(^PS(52.41,PENDING,0),"^",9)=$P($G(^PSRX(PSORXFL,0)),"^",6)
"RTN","PSOHLNE2",122,0)
 S $P(^PS(52.41,PENDING,"INI"),"^")=$G(PSINPTR) D NOW^%DTC S $P(^PS(52.41,PENDING,0),"^",12)=% K %
"RTN","PSOHLNE2",123,0)
 K DIK S DA=PENDING,DIK="^PS(52.41," D IX1^DIK K DIK
"RTN","PSOHLNE2",124,0)
 G REFSND
"RTN","PSOHLNE2",125,0)
PIDZ ;
"RTN","PSOHLNE2",126,0)
 S DFN=+$P(REFSEG,"|",3)
"RTN","PSOHLNE2",127,0)
 Q
"RTN","PSOHLNE2",128,0)
PV1Z ;
"RTN","PSOHLNE2",129,0)
 S LOCATION=+$P(+$P(REFSEG,"|",3),"^")
"RTN","PSOHLNE2",130,0)
 S:'$D(^SC(LOCATION,0)) LOCATION=""
"RTN","PSOHLNE2",131,0)
 S INPTRX=0 I $G(LOCATION) S PSINPTR=$P($G(^SC(LOCATION,0)),"^",4) I PSINPTR Q
"RTN","PSOHLNE2",132,0)
 I $G(LOCATION) S INPTRX=$P($G(^SC(LOCATION,0)),"^",15)
"RTN","PSOHLNE2",133,0)
 I '$G(INPTRX) S INPTRX=$O(^DG(40.8,0))
"RTN","PSOHLNE2",134,0)
 I '$G(DT) S DT=$$DT^XLFDT
"RTN","PSOHLNE2",135,0)
 S PSINPTR=+$$SITE^VASITE(DT,INPTRX)
"RTN","PSOHLNE2",136,0)
 Q
"RTN","PSOHLNE2",137,0)
ORCZ ;
"RTN","PSOHLNE2",138,0)
 S PLACER=+$P(REFSEG,"|",2),REFILLER=+$P(REFSEG,"|",3),ENTERED=+$P(REFSEG,"|",10),PROV=+$P(REFSEG,"|",12)
"RTN","PSOHLNE2",139,0)
 Q
"RTN","PSOHLNE2",140,0)
ZRXZ ;
"RTN","PSOHLNE2",141,0)
 S ROUTING=$P(REFSEG,"|",4)
"RTN","PSOHLNE2",142,0)
 Q
"RTN","PSOHLNE2",143,0)
STUFF ;
"RTN","PSOHLNE2",144,0)
 S PSOVRBD=$P($G(^PS(50.7,+$G(PSORDITE),0)),"^",2)
"RTN","PSOHLNE2",145,0)
 I '$G(PSOVRBD) K PSOVRBD Q
"RTN","PSOHLNE2",146,0)
 S PSOVRB=$P($G(^PS(50.606,PSOVRBD,"MISC")),"^")
"RTN","PSOHLNE2",147,0)
 F EE=0:0 S EE=$O(^PS(52.41,PENDING,1,EE)) Q:'EE  S $P(^PS(52.41,PENDING,1,EE,1),"^",10)=$$UNESC^ORHLESC($G(PSOVRB))
"RTN","PSOHLNE2",148,0)
 K PSOVRBD,PSONUNN,PSONUN,PSOVRB
"RTN","PSOHLNE2",149,0)
 Q
"RTN","PSOHLNEW")
0^39^B86108957^B83121604
"RTN","PSOHLNEW",1,0)
PSOHLNEW ;BIR/RTR - CPRS orders ;11/30/06 11:49am
"RTN","PSOHLNEW",2,0)
 ;;7.0;OUTPATIENT PHARMACY;**1,7,15,46,71,98,111,124,117,131,146,132,143,223,235,148,239,249,225,324,251,387,379,391**;DEC 1997;Build 13
"RTN","PSOHLNEW",3,0)
 ;External reference to EN^ORERR supported by DBIA 2187
"RTN","PSOHLNEW",4,0)
 ;External reference to ^PS(50.7 supported by DBIA 2223 
"RTN","PSOHLNEW",5,0)
 ;External reference to ^DG(40.8 supported by DBIA 728
"RTN","PSOHLNEW",6,0)
 ;External reference to ^OR(100 supported by DBIA 2219
"RTN","PSOHLNEW",7,0)
 ;External reference to ^SC( supported by DBIA 2675
"RTN","PSOHLNEW",8,0)
 ;External reference to ^PSDRUG( supported by DBIA 2675
"RTN","PSOHLNEW",9,0)
EN(MSG) ;
"RTN","PSOHLNEW",10,0)
 N PSODDRUG,ENTERED,LOCATION,PLACER,PSOOC,ROUTE,NATURE,PREV,ROUTING,OO,OR,STAT,ZZ,DFN,COMM,QCOUNT,OCOUNT,Q1I,QTARRAY,QTARRAY2,EE,PP,XOFLAG,PSODYSPL,PSOFILNM
"RTN","PSOHLNEW",11,0)
 N ONEFLAG,SERV,WPCT,EFFECT,PROV,PENDING,RRX,PSOLQ1I,PSOLQ1II,PSOQWX,PSOLQ1IX,PSONVA,PSOICD,PSOSCP,EEE,Q9
"RTN","PSOHLNEW",12,0)
 N OBXAR,AA,II,SIG1,FILLER,COMM,GG,FF,JJ,JJJ,CT,LIM,VAR,VAR1,QQQ,PSRNFLAG,PSRNQFLG,RCOMM,XOFLAGZ,NWFLAG,PFLAG,PSINPTR,INPTRX,PSOIBN,PSOIBY
"RTN","PSOHLNEW",13,0)
 N DSIG,DDR,PSOCHFFL,PSOCVI,PSOMO,PSOXRP,NN,LL,LLL,WPARRAY,QTVAR,POVAR,POVAR1,ORCSEG,NNN,OOO,AAA,NNNN,POLIM,NNCK,PRIOR,IPPLACER,PLACERXX,EER,PSERRPID,PSERRPV1,PSERRORC,PSOEXFLG,PSOMSORR,PDFN,VAL
"RTN","PSOHLNEW",14,0)
 S (SEND,PSOSND,OCOUNT)=0 K PSOPLC,PSOFFL,PSORSO,PSOSUSZ
"RTN","PSOHLNEW",15,0)
 F OO=0:0 S OO=$O(MSG(OO)) Q:'OO!(SEND)!(PSOSND)  D:$P(MSG(OO),"|")="PID" SPDFN I $P(MSG(OO),"|")="ORC",$P(MSG(OO),"|",2)'="NW",$P(MSG(OO),"|",2)'="XO" D
"RTN","PSOHLNEW",16,0)
 .S OR("STAT")=$P(MSG(OO),"|",2),OR("PLACE")=+$P(MSG(OO),"|",3),PLACERXX=+$P($P(MSG(OO),"|",3),";",2),OR("COMM")=$P(MSG(OO),"|",17),OR("USER")=$P(MSG(OO),"|",11) I $P(MSG(OO),"|",2)'="DE",$P(MSG(OO),"|",2)'="NA" S SEND=1 D FILL Q
"RTN","PSOHLNEW",17,0)
 .S PSOPLC=+$P(MSG(OO),"|",3),PSOFFL=+$P(MSG(OO),"|",4),PSOSND=1,PSOCHFFL=$P($P(MSG(OO),"|",4),"^")
"RTN","PSOHLNEW",18,0)
 I $G(OR("COMM"))["^" S OR("COMM")=$P(OR("COMM"),"^",5)
"RTN","PSOHLNEW",19,0)
 I PSOSND,$G(PSOCHFFL)["S",$G(OR("STAT"))="NA" D CHCS^PSOHLNE1 Q
"RTN","PSOHLNEW",20,0)
 I PSOSND,'$D(^PSRX(+$G(PSOFFL),0)) S COMM="Order was not located by Pharmacy" D EN^ORERR(COMM,.MSG) D KL Q
"RTN","PSOHLNEW",21,0)
 I PSOSND,$G(PDFN),PDFN'=+$P($G(^PSRX(+$G(PSOFFL),0)),"^",2) S COMM="Patient does not match" D EN^ORERR(COMM,.MSG) D KL Q
"RTN","PSOHLNEW",22,0)
 I PSOSND,$G(OR("STAT"))'="DE" N PSONAS S PSONAS=$S($P($G(^PSRX(PSOFFL,"OR1")),"^",2)="":1,1:0) S $P(^PSRX(PSOFFL,"OR1"),"^",2)=PSOPLC,^PSRX("APL",PSOPLC,PSOFFL)="" D:PSONAS EN^PSOHDR("PRES",PSOFFL) D KL Q
"RTN","PSOHLNEW",23,0)
 D KL
"RTN","PSOHLNEW",24,0)
 I SEND,$G(OR("STAT"))="Z@" G PURGE^PSOHLNE2
"RTN","PSOHLNEW",25,0)
 I SEND,$G(OR("STAT"))="ZF" G REF^PSOHLNE2
"RTN","PSOHLNEW",26,0)
 I SEND,$G(OR("STAT"))'="CA",$G(OR("STAT"))'="DC",$G(OR("STAT"))'="HD",$G(OR("STAT"))'="RL",$G(OR("STAT"))'="SS" S RCOMM="Invalid Order Control Code" D EN^ORERR(RCOMM,.MSG) Q
"RTN","PSOHLNEW",27,0)
 I SEND K SEND G:$G(OR("STAT"))="SS" ESTAT D EN^PSOORUTL(.OR) S PLACER=OR("PLACE"),STAT=OR("STAT"),COMM=OR("COMM") S PSOMSORR=1 D  K PSOMSORR Q
"RTN","PSOHLNEW",28,0)
 .I $G(OR("FILLER"))="" D  D ERROR^PSOHLSN Q
"RTN","PSOHLNEW",29,0)
 ..F EER=0:0 S EER=$O(MSG(EER)) Q:'EER  S:$P(MSG(EER),"|")="PV1" PSERRPV1=MSG(EER) S:$P(MSG(EER),"|")="PID" PSERRPID=MSG(EER) S:$P(MSG(EER),"|")="ORC"&($G(PSERRORC)="") PSERRORC=MSG(EER)
"RTN","PSOHLNEW",30,0)
 .I $P(OR("FILLER"),"^",2)="R" S FILLER=$P(OR("FILLER"),"^") D EN^PSOHLSN1(FILLER,STAT,$G(OR("PHARMST")),COMM) K:$G(PSOEXFLG) PSOMSORR,PLACERXX D:$G(PSOEXFLG) EN^PSOHLSN1(FILLER,"SC","ZE","") D:$G(PSOSUSZ) SUS^PSOORUT1 K PSOSUSZ Q
"RTN","PSOHLNEW",31,0)
 .D EN^PSOHLSN(PLACER,STAT,COMM) Q
"RTN","PSOHLNEW",32,0)
 D KL^PSOHLSIH S RRX=1 F ZZ=0:0 S ZZ=$O(MSG(ZZ)) Q:'ZZ  S PSOSEG=$G(MSG(ZZ)),PSOTYPE=$P(PSOSEG,"|") S PSOSEG=$E(PSOSEG,5,$L(PSOSEG)) I PSOTYPE'="NTE" D @PSOTYPE
"RTN","PSOHLNEW",33,0)
 I $G(PSRNFLAG) S PSOMO=0 D MISRN^PSOHLNE1 I $G(PSOMO) Q
"RTN","PSOHLNEW",34,0)
 S PSRNQFLG=0 I $G(PSRNFLAG),$G(PREV) D  I $G(PSRNQFLG) S RCOMM="Duplicate Renewal Request. Order rejected by Pharmacy." D EN^ORERR(RCOMM,.MSG) D RERROR^PSOHLSN D KL^PSOHLSIH Q
"RTN","PSOHLNEW",35,0)
 .I $P($G(^PSRX(PREV,"OR1")),"^",4) S PSRNQFLG=1 Q
"RTN","PSOHLNEW",36,0)
 .I $O(^PS(52.41,"AQ",PREV,0)) S PSRNQFLG=1
"RTN","PSOHLNEW",37,0)
 .I $G(XOFLAG),$G(DFN)'=$S($G(PFLAG):$P($G(^PS(52.41,+$G(PREV),0)),"^",2),1:$P($G(^PSRX(+$G(PREV),0)),"^",2)) S RCOMM="Patient mismatch on previous order." D EN^ORERR(RCOMM,.MSG) S XOFLAGZ=1 D RERROR^PSOHLSN D KL^PSOHLSIH Q
"RTN","PSOHLNEW",38,0)
 I $G(PLACER) I $G(DFN)'=+$P($G(^OR(100,+PLACER,0)),"^",2) G MISX^PSOHLNE1
"RTN","PSOHLNEW",39,0)
 I $G(PLACER) D NFILE
"RTN","PSOHLNEW",40,0)
 D KL^PSOHLSIH
"RTN","PSOHLNEW",41,0)
 Q
"RTN","PSOHLNEW",42,0)
ESTAT ;
"RTN","PSOHLNEW",43,0)
 D EXP^PSOHLNE1
"RTN","PSOHLNEW",44,0)
 Q
"RTN","PSOHLNEW",45,0)
MSH Q
"RTN","PSOHLNEW",46,0)
PID S DFN=+$P(PSOSEG,"|",3)
"RTN","PSOHLNEW",47,0)
 Q
"RTN","PSOHLNEW",48,0)
PV1 S LOCATION=+$P(+$P(PSOSEG,"|",3),"^")
"RTN","PSOHLNEW",49,0)
 S:'$D(^SC(LOCATION,0)) LOCATION=""
"RTN","PSOHLNEW",50,0)
 S INPTRX=0 I $G(LOCATION) S PSINPTR=$P($G(^SC(LOCATION,0)),"^",4) I PSINPTR Q
"RTN","PSOHLNEW",51,0)
 I $G(LOCATION) S INPTRX=$P($G(^SC(LOCATION,0)),"^",15)
"RTN","PSOHLNEW",52,0)
 I '$G(INPTRX) S INPTRX=$O(^DG(40.8,0))
"RTN","PSOHLNEW",53,0)
 I '$G(DT) S DT=$$DT^XLFDT
"RTN","PSOHLNEW",54,0)
 S PSINPTR=+$$SITE^VASITE(DT,INPTRX)
"RTN","PSOHLNEW",55,0)
 Q
"RTN","PSOHLNEW",56,0)
OBR ;This segment is used to pass flagging information from CPRS.
"RTN","PSOHLNEW",57,0)
 D OBR^PSOHLNE4
"RTN","PSOHLNEW",58,0)
 Q
"RTN","PSOHLNEW",59,0)
DG1 S $P(PSOICD($P(PSOSEG,"|",1)),"^")=$P($P(PSOSEG,"|",3),"^")
"RTN","PSOHLNEW",60,0)
 Q
"RTN","PSOHLNEW",61,0)
ORC ;
"RTN","PSOHLNEW",62,0)
 Q:$P(PSOSEG,"|")="DE"
"RTN","PSOHLNEW",63,0)
 S:$P(PSOSEG,"|")="XO" XOFLAG=1 D ^PSOHLNE1 S:$G(PRIOR)="A" PRIOR="E" S:$G(PRIOR)="" PRIOR="R"
"RTN","PSOHLNEW",64,0)
 Q
"RTN","PSOHLNEW",65,0)
 ;
"RTN","PSOHLNEW",66,0)
RXO I $O(MSG(ZZ,0)) D ^PSOHLNE2 G RXOPS
"RTN","PSOHLNEW",67,0)
 S PSORDITE=$P($P(PSOSEG,"|"),"^",4)
"RTN","PSOHLNEW",68,0)
 S PSODDRUG=$P($P(PSOSEG,"|",10),"^",4) I $G(PSODDRUG) S DDR=1 S:'$D(^PSDRUG(PSODDRUG,0)) PSODDRUG=""
"RTN","PSOHLNEW",69,0)
 S PSOXQTY=$P(PSOSEG,"|",11)
"RTN","PSOHLNEW",70,0)
 S PSOREFIL=$P(PSOSEG,"|",13)
"RTN","PSOHLNEW",71,0)
 S PSODYSPL=$P(PSOSEG,"|",17)
"RTN","PSOHLNEW",72,0)
RXOPS S ONEFLAG=0,WPCT=1,LL=ZZ+1
"RTN","PSOHLNEW",73,0)
 I $P($G(MSG(LL)),"|")="NTE" D
"RTN","PSOHLNEW",74,0)
 .S ONEFLAG=1,WORDP=$S($P(MSG(LL),"|",2):$P(MSG(LL),"|",2),1:$P(MSG(LL),"|",3)) S:$P(MSG(LL),"|",4)'="" WPARRAY(WORDP,WPCT)=$P(MSG(LL),"|",4) S:$P(MSG(LL),"|",4)'="" WPCT=WPCT+1 F LLL=0:0 S LLL=$O(MSG(LL,LLL)) Q:'LLL  D
"RTN","PSOHLNEW",75,0)
 ..I $G(MSG(LL,LLL))'="" S WPARRAY(WORDP,WPCT)=$G(MSG(LL,LLL)),WPCT=WPCT+1
"RTN","PSOHLNEW",76,0)
 I ONEFLAG S LL=LL+1 I $P($G(MSG(LL)),"|")="NTE" D NTE^PSOHLNE1
"RTN","PSOHLNEW",77,0)
 K WORDP
"RTN","PSOHLNEW",78,0)
 Q
"RTN","PSOHLNEW",79,0)
RXR I $P($P(PSOSEG,"|"),"^",4) S ROUTE(RRX)=$P($P(PSOSEG,"|"),"^",4) S RRX=RRX+1
"RTN","PSOHLNEW",80,0)
 Q
"RTN","PSOHLNEW",81,0)
OBX I $O(MSG(ZZ,0)) D OBXX^PSOHLNE2 G OBXNTE
"RTN","PSOHLNEW",82,0)
 S OCOUNT=OCOUNT+1
"RTN","PSOHLNEW",83,0)
 S OBXAR(OCOUNT,1)=$P(PSOSEG,"|",5)
"RTN","PSOHLNEW",84,0)
OBXNTE ;
"RTN","PSOHLNEW",85,0)
 D OBXNTE^PSOHLNE3
"RTN","PSOHLNEW",86,0)
 Q
"RTN","PSOHLNEW",87,0)
ZRN S PSODSC=1_"^"_$P(PSOSEG,"|",2)
"RTN","PSOHLNEW",88,0)
 I $O(MSG(ZZ,0)) F T=0:0 S T=$O(MSG(ZZ,T)) Q:'T  S PSODSC(T)=MSG(ZZ,T)
"RTN","PSOHLNEW",89,0)
 K T
"RTN","PSOHLNEW",90,0)
 Q
"RTN","PSOHLNEW",91,0)
 ;
"RTN","PSOHLNEW",92,0)
ZRX D ZRX^PSOHLNE1
"RTN","PSOHLNEW",93,0)
 Q
"RTN","PSOHLNEW",94,0)
 ;
"RTN","PSOHLNEW",95,0)
ZCL D ZCL^PSOHLNE1
"RTN","PSOHLNEW",96,0)
 Q
"RTN","PSOHLNEW",97,0)
ZSC D CP^PSOHLNE1
"RTN","PSOHLNEW",98,0)
 Q
"RTN","PSOHLNEW",99,0)
NFILE ;
"RTN","PSOHLNEW",100,0)
 I $G(PSODSC) D ^PSONVNEW Q  ;adds non-va med to #55
"RTN","PSOHLNEW",101,0)
 ;
"RTN","PSOHLNEW",102,0)
 K DD,DO,DIC S DLAYGO="52.41",DIC="^PS(52.41,",DIC(0)="L",X=PLACER,DIC("DR")="1////"_DFN_";2////"_PSOOC_";6////"_$G(EFFECT)_";12////"_$G(PSOXQTY)_";25////"_$G(PRIOR)
"RTN","PSOHLNEW",103,0)
 S DIC("DR")=DIC("DR")_";22////"_$G(PSORSO)_";22.1////"_$G(PREV)_";19////"_$G(ROUTING)_";17////"_$$UNESC^ORHLESC($G(SERV))_";7////"_$G(NATURE)_";13////"_$G(PSOREFIL)_";1.1////"_$G(LOCATION)_";117////"_$G(DSIG)_$S($G(DSIG):";118////"_$G(DDR),1:"")
"RTN","PSOHLNEW",104,0)
 D FILE^DICN K DIC,DR I Y<0 Q
"RTN","PSOHLNEW",105,0)
 S PENDING=+Y
"RTN","PSOHLNEW",106,0)
 S $P(^PS(52.41,PENDING,0),"^",4)=$S($G(ENTERED):+$G(ENTERED),1:""),$P(^(0),"^",5)=$S($G(PROV):+$G(PROV),1:""),$P(^(0),"^",8)=$S($G(PSORDITE):+$G(PSORDITE),1:""),$P(^(0),"^",9)=$S($G(PSODDRUG):+$G(PSODDRUG),1:""),$P(^(0),"^",15)=$G(ROUTE)
"RTN","PSOHLNEW",107,0)
 S ^PS(52.41,PENDING,"IBQ")=$G(PSOIBY)
"RTN","PSOHLNEW",108,0)
 I $G(PSODYSPL)'="",$E(PSODYSPL)?1A S PSODYSPL=$E(PSODYSPL,2,$L(PSODYSPL))
"RTN","PSOHLNEW",109,0)
 S $P(^PS(52.41,PENDING,"INI"),"^")=$G(PSINPTR),$P(^(0),"^",12)=$G(PSOLOG),$P(^(0),"^",22)=$G(PSODYSPL)
"RTN","PSOHLNEW",110,0)
 I $G(QCOUNT) S ^PS(52.41,PENDING,1,0)="^52.413^"_QCOUNT_"^"_QCOUNT
"RTN","PSOHLNEW",111,0)
 S PSOQWX=$G(PSODDRUG) D:'$G(PSOQWX) OID^PSOHLNE1
"RTN","PSOHLNEW",112,0)
 F PP=0:0 S PP=$O(Q1I(PP)) Q:'PP  S VAL=$S($G(PSOQWX)&($G(PSOLQ1II(PP))):Q1I(PP),$G(PSOQWX)&($G(PSOLQ1IX(PP))'="")&('$G(PSOLQ1II(PP))):PSOLQ1IX(PP),1:PSOLQ1I(PP)) S ^PS(52.41,PENDING,1,PP,0)=$$UNESC^ORHLESC(VAL)
"RTN","PSOHLNEW",113,0)
 F EE=0:0 S EE=$O(QTARRAY(EE)) Q:'EE  S ^PS(52.41,PENDING,1,EE,1)=$$UNESC^ORHLESC(QTARRAY(EE)) S VAL=$S($G(PSOQWX)&($G(PSOLQ1II(EE))):$G(QTARRAY2(EE)),$G(PSOQWX)&($G(PSOLQ1IX(EE))'="")&('$G(PSOLQ1II(EE))):PSOLQ1IX(EE),1:$G(PSOLQ1I(EE))) D
"RTN","PSOHLNEW",114,0)
 .S ^PS(52.41,PENDING,1,EE,2)=$$UNESC^ORHLESC(VAL) S $P(^PS(52.41,PENDING,1,EE,1),"^",8)=+$G(ROUTE(EE))
"RTN","PSOHLNEW",115,0)
 I $G(DSIG) D
"RTN","PSOHLNEW",116,0)
 .S EE=0 F QCOUNT=0:1 S EE=$O(Q9(EE)) Q:'EE  S ^PS(52.41,PENDING,9,EE,0)=$$UNESC^ORHLESC(Q9(EE))
"RTN","PSOHLNEW",117,0)
 .I QCOUNT S ^PS(52.41,PENDING,9,0)="^52.44^"_QCOUNT_"^"_QCOUNT
"RTN","PSOHLNEW",118,0)
 S:$P($G(^PS(52.41,PENDING,1,1,1)),"^",3) $P(^PS(52.41,PENDING,0),"^",18)=$E($P($G(^PS(52.41,PENDING,1,1,1)),"^",3),1,7)
"RTN","PSOHLNEW",119,0)
 D STUFF^PSOHLNE2
"RTN","PSOHLNEW",120,0)
 D ^PSOHLPII
"RTN","PSOHLNEW",121,0)
 S LL=0 I $O(WPARRAY(6,0)) F LLL=0:0 S LLL=$O(WPARRAY(6,LLL)) Q:'LLL  S LL=LL+1 S ^PS(52.41,PENDING,3,LL,0)=$$UNESC^ORHLESC($G(WPARRAY(6,LLL)))
"RTN","PSOHLNEW",122,0)
 I LL S ^PS(52.41,PENDING,3,0)="^52.42^"_LL_"^"_LL
"RTN","PSOHLNEW",123,0)
 S LL=0 I $O(WPARRAY(7,0)) F LLL=0:0 S LLL=$O(WPARRAY(7,LLL)) Q:'LLL  S LL=LL+1 S ^PS(52.41,PENDING,"INS1",LL,0)=$$UNESC^ORHLESC($G(WPARRAY(7,LLL)))
"RTN","PSOHLNEW",124,0)
 I LL S ^PS(52.41,PENDING,"INS1",0)="^^"_LL_"^"_LL_"^"_$G(DT)_"^"
"RTN","PSOHLNEW",125,0)
 I $P($G(^PS(50.7,+$G(PSORDITE),"INS")),"^")'="" S $P(^PS(52.41,PENDING,"INS"),"^",2)=$S($O(^PS(52.41,PENDING,"INS1",0)):1,1:0)
"RTN","PSOHLNEW",126,0)
 I $G(OCOUNT) S ^PS(52.41,PENDING,"OBX",0)="^52.4118A^"_OCOUNT_"^"_OCOUNT F OCOUNT=1:1:OCOUNT D
"RTN","PSOHLNEW",127,0)
 .S ^PS(52.41,PENDING,"OBX",OCOUNT,0)=$$UNESC^ORHLESC($G(OBXAR(OCOUNT,1)))
"RTN","PSOHLNEW",128,0)
 .D USER^PSOORFI2(+$G(PROV)) S ^PS(52.41,PENDING,"OBX",OCOUNT,1)=$$UNESC^ORHLESC(USER1) K USER1
"RTN","PSOHLNEW",129,0)
 .S PSOBCT=1 F LLL=2:1 Q:'$D(OBXAR(OCOUNT,LLL))  S ^PS(52.41,PENDING,"OBX",OCOUNT,2,PSOBCT,0)=$$UNESC^ORHLESC(OBXAR(OCOUNT,LLL)),^PS(52.41,PENDING,"OBX",OCOUNT,2,0)="^^"_PSOBCT_"^"_PSOBCT_"^"_$G(DT)_"^"
"RTN","PSOHLNEW",130,0)
 D ^PSOHLPIS
"RTN","PSOHLNEW",131,0)
 K DIK S DIK="^PS(52.41,",DA=PENDING D IX^DIK
"RTN","PSOHLNEW",132,0)
 I $G(PSOOC)="RNW",$G(PREV),$D(^PSRX(+$G(PREV),0)) D EN^PSOHLSN1(PREV,"SC","ZZ","")
"RTN","PSOHLNEW",133,0)
 S PSOMSORR=1,IPPLACER=$P($G(^PS(52.41,PENDING,0)),"^") I IPPLACER D
"RTN","PSOHLNEW",134,0)
 .I '$G(XOFLAG) D EN^PSOHLSN(IPPLACER,"OK","IP") Q
"RTN","PSOHLNEW",135,0)
 .D EN^PSOHLSN(IPPLACER,"XR","IP") I $G(PFLAG) D DCP^PSOHLSN Q
"RTN","PSOHLNEW",136,0)
 .K PSOMSORR I $D(^PSRX(+$G(PREV),0)) D  D EN^PSOHLSN1(PREV,"RP","","","A")
"RTN","PSOHLNEW",137,0)
 ..S $P(^PSRX(PREV,"STA"),"^")=15,$P(^(3),"^",5)=DT,$P(^(3),"^",10)=$P(^(3),"^"),$P(^(7),"^")=2
"RTN","PSOHLNEW",138,0)
 ..D CHKCMOP^PSOUTL(PREV)
"RTN","PSOHLNEW",139,0)
 ..D REVERSE^PSOBPSU1(PREV,,"DC",7),CAN^PSOTPCAN(PREV),CAN^PSOUTL(PREV)
"RTN","PSOHLNEW",140,0)
 ..D CNT^PSOHLNE1
"RTN","PSOHLNEW",141,0)
 ..D:$G(^PS(52.41,PENDING,1,1,0))=""&($P($G(^PS(52.41,PENDING,1,1,1)),"^")="")&($G(^PS(52.41,PENDING,"SIG",1,0))="")
"RTN","PSOHLNEW",142,0)
 ...N FSIG,BSIG
"RTN","PSOHLNEW",143,0)
 ...I '$P($G(^PSRX(PREV,"SIG")),"^",2),$P($G(^("SIG")),"^")'="" D
"RTN","PSOHLNEW",144,0)
 ....D EN3^PSOUTLA1(PREV,70)
"RTN","PSOHLNEW",145,0)
 ....I $G(BSIG(1))'="" S ^PS(52.41,PENDING,"SIG",1,0)=$$UNESC^ORHLESC($G(BSIG(1))) I $O(BSIG(1)) F EE=1:0 S EE=$O(BSIG(EE)) Q:'EE  S ^PS(52.41,PENDING,"SIG",EE,0)=$$UNESC^ORHLESC($G(BSIG(EE)))
"RTN","PSOHLNEW",146,0)
 ...I $P($G(^PSRX(PREV,"SIG")),"^",2),$G(^PSRX(PREV,"SIG1",1,0))'="" D
"RTN","PSOHLNEW",147,0)
 ....D FSIG^PSOUTLA("R",PREV,70)
"RTN","PSOHLNEW",148,0)
 ....I $G(FSIG(1))'="" S ^PS(52.41,PENDING,"SIG",1,0)=$$UNESC^ORHLESC($G(FSIG(1))) I $O(FSIG(1)) F EE=1:0 S EE=$O(FSIG(EE)) Q:'EE  S ^PS(52.41,PENDING,"SIG",EE,0)=$$UNESC^ORHLESC($G(FSIG(EE)))
"RTN","PSOHLNEW",149,0)
 ...F EE=0:0 S EE=$O(^PS(52.41,PENDING,"SIG",EE)) Q:'EE  S ^PS(52.41,PENDING,"SIG",0)="^52.4124A^"_EE_"^"_EE
"RTN","PSOHLNEW",150,0)
 D CSET^PSODIAG
"RTN","PSOHLNEW",151,0)
 Q
"RTN","PSOHLNEW",152,0)
SPDFN S PDFN=$P($G(MSG(OO)),"|",4) Q
"RTN","PSOHLNEW",153,0)
KL K PSOPLC,PSOFFL,PSOSND
"RTN","PSOHLNEW",154,0)
 Q
"RTN","PSOHLNEW",155,0)
FILL ;
"RTN","PSOHLNEW",156,0)
 S (PSOFILNM,OR("PSOFILNM"))=$P($P(MSG(OO),"|",4),"^")
"RTN","PSOHLNEW",157,0)
 Q
"RTN","PSOLLL2")
0^42^B16898415^B16255333
"RTN","PSOLLL2",1,0)
PSOLLL2 ;BIR/JLC-LASER LABEL ;11/19/02
"RTN","PSOLLL2",2,0)
 ;;7.0;OUTPATIENT PHARMACY;**120,138,141,161,200,391**;DEC 1997;Build 13
"RTN","PSOLLL2",3,0)
 ;
"RTN","PSOLLL2",4,0)
 ;Reference to $$ECMEON^BPSUTIL supported by DBIA 4410
"RTN","PSOLLL2",5,0)
L1 I $G(PSOIO("PFDI"))]"" X PSOIO("PFDI")
"RTN","PSOLLL2",6,0)
 I '$G(PFF) D
"RTN","PSOLLL2",7,0)
 .N PGY
"RTN","PSOLLL2",8,0)
 .M PGY=SGY I $D(OSGY) K PGY M PGY=OSGY
"RTN","PSOLLL2",9,0)
 .D COUNTSGF^PSOLLLW
"RTN","PSOLLL2",10,0)
 S PFM=0,T=$S($D(REPRINT)&($G(PSOBLALL)):"(GROUP REPRINT)",$D(REPRINT):"(REPRINT)",1:"")
"RTN","PSOLLL2",11,0)
 S T=T_$S($G(RXP):"(PARTIAL)",1:"")_$S($D(REPRINT):" ",$G(RXP):" ",1:"")_$P(PS2,"^",2)_"  "_TECH_"  "_$P(PSONOWT,":",1,2) D PRINT(T)
"RTN","PSOLLL2",12,0)
 S T="Rx# "_RXN_"  "_DATE_"  "_$S('PFF:"Fill "_(RXF+1)_" of "_(1+$P(RXY,"^",9)),1:"(fill document continued)") D PRINT(T)
"RTN","PSOLLL2",13,0)
 I $D(^PSRX(RX,"PKI")) S SSNPN=^PSRX(RX,"PKI"),SSNPN=$S(SSNPN:"(DSIG)",$P(SSNPN,"^",2):"(NOT DSIG)",1:"")
"RTN","PSOLLL2",14,0)
 S T=PNM_" "_$G(SSNPN) D PRINT(T,1) S SSNPN=""
"RTN","PSOLLL2",15,0)
 S LENGTH=0,PTEXT="",PFF=0,XFONT=$E(PSOFONT,2,99)
"RTN","PSOLLL2",16,0)
 N DP,TEXTP,TEXTL,MORE
"RTN","PSOLLL2",17,0)
 S DR=PFF("DR")
"RTN","PSOLLL2",18,0)
 F I=1:1 Q:'$D(NPGY(DR,I))  S TEXT=NPGY(DR,I) D PRINT(TEXT)
"RTN","PSOLLL2",19,0)
 I I>4,$D(NPGY(DR,5)) S PFF=1,PFF("DR")=DR+1
"RTN","PSOLLL2",20,0)
 S OPSOY=PSOY
"RTN","PSOLLL2",21,0)
 I $G(PSOIO("PFDQ"))]"" X PSOIO("PFDQ")
"RTN","PSOLLL2",22,0)
 I PFF S PSOX=PSOCX,PSOY=OPSOY,T="(continued on next fill document)" S PFM=1 D PRINT(T) Q
"RTN","PSOLLL2",23,0)
 K NPGY,^TMP($J,"PSOSIGF")
"RTN","PSOLLL2",24,0)
 S XFONT=$E(PSOQFONT,2,99)
"RTN","PSOLLL2",25,0)
 S TEXT="Qty: " D STRT^PSOLLU1("SIG2",TEXT,.L) S Q(1)=L(XFONT)
"RTN","PSOLLL2",26,0)
 S TEXT=" "_PSDU D STRT^PSOLLU1("SIG2",TEXT,.L) S Q(2)=L(XFONT)
"RTN","PSOLLL2",27,0)
 S TEXT="       "_$G(PHYS) D STRT^PSOLLU1("SIG2",TEXT,.L) S Q(3)=L(XFONT)
"RTN","PSOLLL2",28,0)
 S PPHYS=$G(PHYS)
"RTN","PSOLLL2",29,0)
 S TEXT=$G(QTY) D STRT^PSOLLU1("SIG2",TEXT,.L) S LENGTH=Q(1)+Q(2)+Q(3)+L(XFONT+2),Q(4)=L(XFONT+2)
"RTN","PSOLLL2",30,0)
 I LENGTH>3.7 F I=$L(PHYS)-1:-1:1 S PPHYS=$E(PHYS,1,I),TEXT="       "_PPHYS D STRT^PSOLLU1("SIG2",TEXT,.L) I Q(1)+Q(2)+Q(4)+L(XFONT)<3.7 Q
"RTN","PSOLLL2",31,0)
 S OPSOX=PSOX,PSOX=Q(1)*300+OPSOX,T=$G(QTY) D PRINT(T) S PSOX=OPSOX
"RTN","PSOLLL2",32,0)
 S PSOFONT=PSOQFONT,PSOY=PSOY-PSOYI,T="Qty: " D PRINT(T)
"RTN","PSOLLL2",33,0)
 S PSOY=PSOY-PSOYI,PSOX=Q(1)+Q(4)*300+OPSOX,T=" "_$G(PSDU)_"       "_$G(PPHYS) D PRINT(T)
"RTN","PSOLLL2",34,0)
 I $G(PSOIO("PFDT"))]"" X PSOIO("PFDT")
"RTN","PSOLLL2",35,0)
 S T=DRUG D PRINT(T)
"RTN","PSOLLL2",36,0)
L11 ;
"RTN","PSOLLL2",37,0)
 N NDCTEXT
"RTN","PSOLLL2",38,0)
 S NDCTEXT="NDC/MFR_______________"
"RTN","PSOLLL2",39,0)
 I $$ECMEON^BPSUTIL($$RXSITE^PSOBPSUT(RX,RXF)) S NDCTEXT="NDC "_$$GETNDC^PSONDCUT(RX,RXF)
"RTN","PSOLLL2",40,0)
 S OPSOX=PSOX,T=NDCTEXT D PRINT(T)
"RTN","PSOLLL2",41,0)
 S T="Lot# ___________________" D STRT^PSOLLU1("SIG2",T,.L)
"RTN","PSOLLL2",42,0)
 S PSOY=PSOY-PSOYI,PSOX=L(XFONT+2)*300+OPSOX,T="Lot# _____________________" D PRINT(T)
"RTN","PSOLLL2",43,0)
L12 S PSOX=OPSOX,T="Tech___________________    RPh _____________________" D PRINT(T)
"RTN","PSOLLL2",44,0)
 S PSOFONT=PSOTFONT
"RTN","PSOLLL2",45,0)
 S T="Routing: "_$S("W"[$E(MW):MW,PS55=2:"DO NOT MAIL",1:MW_" MAIL")_"    Days supply: "_$G(DAYS)_"     Cap: "_$S('PSCAP:"SAFETY",1:"") D PRINT(T)
"RTN","PSOLLL2",46,0)
 I PSCAP D
"RTN","PSOLLL2",47,0)
 .D STRT^PSOLLU1("SIG2",T,.L) S LENGTH=L(XFONT+1)
"RTN","PSOLLL2",48,0)
 .S OPSOX=PSOX,T="NON-SAFETY",PSOX=LENGTH*300+OPSOX,PSOY=PSOY-PSOYI D PRINT(T,1) S PSOX=OPSOX
"RTN","PSOLLL2",49,0)
 S T="Isd: "_ISD_"    Exp: "_EXPDT_"    Last Fill: "_$G(PSOFLAST) D PRINT(T)
"RTN","PSOLLL2",50,0)
 S PSOYI=PSOBYI,PSOY=PSOBY
"RTN","PSOLLL2",51,0)
 I $G(PSOIO("SBT"))]"" X PSOIO("SBT")
"RTN","PSOLLL2",52,0)
 S X2=PSOINST_"-"_RX
"RTN","PSOLLL2",53,0)
 W X2
"RTN","PSOLLL2",54,0)
 I $G(PSOIO("EBT"))]"" X PSOIO("EBT")
"RTN","PSOLLL2",55,0)
 I $G(PSOIO("PFDW"))]"" X PSOIO("PFDW")
"RTN","PSOLLL2",56,0)
 S XFONT=$E(PSOFONT,2,99)
"RTN","PSOLLL2",57,0)
 I $G(WARN)'="" S PTEXT="DRUG WARNING " D STRT^PSOLLU1("SIG2",PTEXT,.L) S LENGTH=L(XFONT) D
"RTN","PSOLLL2",58,0)
 . F I=1:1:$L(WARN,",") S TEXT=$P(WARN,",",I)_"," D
"RTN","PSOLLL2",59,0)
 .. D STRT^PSOLLU1("SIG2",TEXT,.L)
"RTN","PSOLLL2",60,0)
 .. I LENGTH+L(XFONT)<1.8 S PTEXT=PTEXT_TEXT,LENGTH=LENGTH+L(XFONT) Q
"RTN","PSOLLL2",61,0)
 .. S LENGTH=0,I=I-1
"RTN","PSOLLL2",62,0)
 .. S T=$P(PTEXT,",",1,$L(PTEXT,",")-1) D PRINT(T) S PTEXT=""
"RTN","PSOLLL2",63,0)
 .. I PSOY>PSOYM W "*"
"RTN","PSOLLL2",64,0)
 . I PTEXT]"" S T=$P(PTEXT,",",1,$L(PTEXT,",")-1) D PRINT(T)
"RTN","PSOLLL2",65,0)
 S PTEXT="Pat. Stat "_PATST_" Clinic: "_PSCLN D STRT^PSOLLU1("SIG2",PTEXT,.L) S T=PTEXT D PRINT(T)
"RTN","PSOLLL2",66,0)
 Q
"RTN","PSOLLL2",67,0)
 ;
"RTN","PSOLLL2",68,0)
PRINT(T,B) ;
"RTN","PSOLLL2",69,0)
 S BOLD=$G(B)
"RTN","PSOLLL2",70,0)
 I 'BOLD,$G(PSOIO(PSOFONT))]"" X PSOIO(PSOFONT)
"RTN","PSOLLL2",71,0)
 I BOLD,$G(PSOIO(PSOFONT_"B"))]"" X PSOIO(PSOFONT_"B")
"RTN","PSOLLL2",72,0)
 I $G(PSOIO("ST"))]"" X PSOIO("ST")
"RTN","PSOLLL2",73,0)
 W T,!
"RTN","PSOLLL2",74,0)
 I $G(PSOIO("ET"))]"" X PSOIO("ET")
"RTN","PSOLLL2",75,0)
 I BOLD,$G(PSOIO(PSOFONT))]"" X PSOIO(PSOFONT) ;TURN OFF BOLDING
"RTN","PSOLLL2",76,0)
 Q
"RTN","PSON52")
0^14^B86376192^B65058460
"RTN","PSON52",1,0)
PSON52 ;BIR/DSD - files new entries in prescription file ;08/09/93
"RTN","PSON52",2,0)
 ;;7.0;OUTPATIENT PHARMACY;**1,16,23,27,32,46,71,111,124,117,131,139,157,143,219,148,239,201,268,260,225,303,358,251,387,379,390.391**;DEC 1997;Build 13
"RTN","PSON52",3,0)
 ;External reference ^PS(55 supported by DBIA 2228
"RTN","PSON52",4,0)
 ;External reference to PSOUL^PSSLOCK supported by DBIA 2789
"RTN","PSON52",5,0)
 ;External reference to ^XUSEC supported by DBIA 10076
"RTN","PSON52",6,0)
 ;External reference SWSTAT^IBBAPI supported by DBIA 4663
"RTN","PSON52",7,0)
 ;External reference SAVNDC^PSSNDCUT supported by DBIA 4707
"RTN","PSON52",8,0)
 ;External reference to $$DS^PSSDSAPI supported by DBIA 5425
"RTN","PSON52",9,0)
EN(PSOX) ;Entry Point
"RTN","PSON52",10,0)
START ;
"RTN","PSON52",11,0)
 D:$D(XRTL) T0^%ZOSV ; Start RT Monitor
"RTN","PSON52",12,0)
 D INIT G:PSON52("QFLG") END D NFILE Q:$G(PSONEW("DFLG"))
"RTN","PSON52",13,0)
 D PS55,DIK
"RTN","PSON52",14,0)
 S:$D(XRT0) XRTN=$T(+0) D:$D(XRT0) T1^%ZOSV ; Stop RT Monitor
"RTN","PSON52",15,0)
 D FINISH
"RTN","PSON52",16,0)
 I $P(^PSRX(PSOX("IRXN"),0),"^",11)="W",$G(^("IB")) S ^PSRX("ACP",$P(^PSRX(PSOX("IRXN"),0),"^",2),$P(^(2),"^",2),0,PSOX("IRXN"))=""
"RTN","PSON52",17,0)
END D EOJ
"RTN","PSON52",18,0)
 Q
"RTN","PSON52",19,0)
INIT ;
"RTN","PSON52",20,0)
 K X,%DT S:$G(PSOID) PSOX("ISSUE DATE")=PSOID
"RTN","PSON52",21,0)
 S PSOX("CS")=0 K PSOX("NOPSDRPH")
"RTN","PSON52",22,0)
 F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSOX("CS"),"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSOX("CS"),"^",2)=1
"RTN","PSON52",23,0)
 I $P($G(PSOX("CS")),"^"),'$D(^XUSEC("PSDRPH",DUZ)) S PSOX("NOPSDRPH")=1
"RTN","PSON52",24,0)
 S PSON52("QFLG")=0,X1=PSOX("ISSUE DATE"),X2=PSOX("DAYS SUPPLY")*(PSOX("# OF REFILLS")+1)\1
"RTN","PSON52",25,0)
 I $D(CLOZPAT) S X2=$S(X2=14:14,X2=7:7,1:X2) G DT
"RTN","PSON52",26,0)
 S X2=$S(PSOX("DAYS SUPPLY")=X2:X2,+$G(PSOX("CS")):184,+$G(DEA("CS")):184,1:366)
"RTN","PSON52",27,0)
 I X2<30 D
"RTN","PSON52",28,0)
 . N % S %=$P($G(PSORX("PATIENT STATUS")),"^"),X2=30
"RTN","PSON52",29,0)
 . S:%?.N %=$P($G(^PS(53,+%,0)),"^") I %["AUTH ABS" S X2=5
"RTN","PSON52",30,0)
DT D C^%DTC S PSOX("STOP DATE")=$P(X,".") K X
"RTN","PSON52",31,0)
 I PSOX("# OF REFILLS")>0 S X1=PSOX("FILL DATE"),X2=$S((PSOX("DAYS SUPPLY")-10\1)<1:1,1:PSOX("DAYS SUPPLY")-10\1) D C^%DTC S PSOX("NEXT POSSIBLE REFILL")=$P(X,".") K X
"RTN","PSON52",32,0)
 S PSOX("TYPE OF RX")=0,PSOX("DISPENSED DATE")=PSOX("FILL DATE") D NOW^%DTC S PSOX("LOGIN DATE")=$S($P($G(OR0),"^",12):$P($G(OR0),"^",12),1:%) K %,X
"RTN","PSON52",33,0)
 S PSOX("STATUS")=$S($G(PSOX("STATUS"))]"":PSOX("STATUS"),$D(PSORX("VERIFY")):1,$D(PSOX("NOPSDRPH")):1,1:0)
"RTN","PSON52",34,0)
 S PSOX("COPIES")=$S($G(PSOX("COPIES"))]"":PSOX("COPIES"),1:1)
"RTN","PSON52",35,0)
 I $G(PSORX("PHARM"))]"" S PSOX("PHARMACIST")=PSORX("PHARM") K PSORX("PHARM")
"RTN","PSON52",36,0)
INITX Q
"RTN","PSON52",37,0)
 ;
"RTN","PSON52",38,0)
NFILE I $G(OR0) D  Q:$G(PSONEW("DFLG"))
"RTN","PSON52",39,0)
 .D NOOR^PSONEW Q:$G(PSONEW("DFLG"))
"RTN","PSON52",40,0)
 .I $G(PSOSIGFL)!($G(PSODRUG("OI"))'=$P(OR0,"^",8)) S PSONEW("CLERK CODE")=DUZ,PSONEW("REMARKS")=$G(PSONEW("REMARKS"))_" CPRS Order #"_$P(OR0,"^")_" Edited."
"RTN","PSON52",41,0)
 S DIC="^PSRX(",DLAYGO=52,DIC(0)="L",X=PSOX("RX #") K DD,DO D FILE^DICN S PSOX("IRXN")=+Y K DLAYGO,X,Y,DIC,DD,DO
"RTN","PSON52",42,0)
 I '$D(^XUSEC("PSORPH",DUZ))!($D(PSOX("NOPSDRPH"))),$$DS^PSSDSAPI&(+$G(^TMP("PSODOSF",$J,0))) S PSON52(PSOX("IRXN"),"STA")=1,PSOX("STATUS")=1
"RTN","PSON52",43,0)
 F PSOX1=0:1 S PSON52=$P($T(DD+PSOX1),";;",2,4) Q:PSON52=""  K PSOY S PSOY=$P(PSON52,";;") I $G(@PSOY)]"" S $P(PSON52(PSOX("IRXN"),$P(PSON52,";;",2)),"^",$P(PSON52,";;",3))=@PSOY
"RTN","PSON52",44,0)
 F I=1:1:PSOX("ENT") S ^PSRX(PSOX("IRXN"),6,I,0)=PSOX("DOSE",I)_"^"_$G(PSOX("DOSE ORDERED",I))_"^"_$G(PSOX("UNITS",I))_"^"_$G(PSOX("NOUN",I))_"^" D
"RTN","PSON52",45,0)
 .S ^PSRX(PSOX("IRXN"),6,I,0)=^PSRX(PSOX("IRXN"),6,I,0)_$G(PSOX("DURATION",I))_"^"_$G(PSOX("CONJUNCTION",I))_"^"_$G(PSOX("ROUTE",I))_"^"_$G(PSOX("SCHEDULE",I))_"^"_$G(PSOX("VERB",I))
"RTN","PSON52",46,0)
 .I $G(PSOX("ODOSE",I))]"" S ^PSRX(PSOX("IRXN"),6,I,1)=PSOX("ODOSE",I)
"RTN","PSON52",47,0)
 S ^PSRX(PSOX("IRXN"),6,0)="^52.0113^"_PSOX("ENT")_"^"_PSOX("ENT")
"RTN","PSON52",48,0)
 K PSOX1,PSOY
"RTN","PSON52",49,0)
 S PSOX1="" F  S PSOX1=$O(PSON52(PSOX("IRXN"),PSOX1)) Q:PSOX1=""  S ^PSRX(PSOX("IRXN"),PSOX1)=$G(PSON52(PSOX("IRXN"),PSOX1))
"RTN","PSON52",50,0)
 I $O(PSOX("SIG",0)) D
"RTN","PSON52",51,0)
 .S D=0 F  S D=$O(PSOX("SIG",D)) Q:'D  S ^PSRX(PSOX("IRXN"),"INS1",D,0)=PSOX("SIG",D),TP=$G(TP)+1
"RTN","PSON52",52,0)
 .S ^PSRX(PSOX("IRXN"),"INS1",0)="^52.0115^"_TP_"^"_TP_"^"_DT_"^^" K TP,D
"RTN","PSON52",53,0)
 I $G(PSOX("SINS"))]"" S ^PSRX(PSOX("IRXN"),"INSS")=PSOX("SINS")
"RTN","PSON52",54,0)
 I $G(SIGOK) D
"RTN","PSON52",55,0)
 .S $P(^PSRX(PSOX("IRXN"),"SIG"),"^",2)=1,^PSRX(PSOX("IRXN"),"SIG1",0)="^52.04A^^"
"RTN","PSON52",56,0)
 .S D=0 F  S D=$O(SIG(D)) Q:'D  S ^PSRX(PSOX("IRXN"),"SIG1",D,0)=SIG(D),$P(^PSRX(PSOX("IRXN"),"SIG1",0),"^",3)=+$P(^PSRX(PSOX("IRXN"),"SIG1",0),"^",3)+1,$P(^(0),"^",4)=+$P(^(0),"^",4)+1 Q:'$O(SIG(D))
"RTN","PSON52",57,0)
 .K SIG
"RTN","PSON52",58,0)
 I $D(PSOINSFL) S ^PSRX(PSOX("IRXN"),"A",0)="^52.3DA^1^1",^PSRX(PSOX("IRXN"),"A",1,0)=DT_"^G^^0^Patient Instructions "_$S(PSOINSFL=1:"",1:"Not ")_"Sent By Provider."
"RTN","PSON52",59,0)
 I $G(OR0),$P(OR0,"^",24) S ^PSRX(PSOX("IRXN"),"PKI")=$S($G(PSOSIGFL):"^1",1:1) D ACLOG
"RTN","PSON52",60,0)
 I $P($G(PSOX("CS")),"^"),'+$P($G(^PSRX(PSOX("IRXN"),"PKI")),"^") S $P(^PSRX(PSOX("IRXN"),"PKI"),"^",2)=1
"RTN","PSON52",61,0)
 K PSOX1,PSOFINFL,HLDSIG,D,PSOINSFL,D
"RTN","PSON52",62,0)
 D:$G(^TMP("PSODAI",$J,0))
"RTN","PSON52",63,0)
 .S $P(^PSRX(PSOX("IRXN"),3),"^",6)=1
"RTN","PSON52",64,0)
 .I $O(^TMP("PSODAI",$J,0)) S DAI=0 F  S DAI=$O(^TMP("PSODAI",$J,DAI)) Q:'DAI  D
"RTN","PSON52",65,0)
 ..S:'$D(^PSRX(PSOX("IRXN"),"DAI",0)) ^PSRX(PSOX("IRXN"),"DAI",0)="^52.03^^" S ^PSRX(PSOX("IRXN"),"DAI",DAI,0)=^TMP("PSODAI",$J,DAI,0)
"RTN","PSON52",66,0)
 ..S $P(^PSRX(PSOX("IRXN"),"DAI",0),"^",3)=+$P(^PSRX(PSOX("IRXN"),"DAI",0),"^",3)+1,$P(^(0),"^",4)=+$P(^(0),"^",4)+1
"RTN","PSON52",67,0)
 .K ^TMP("PSODAI",$J),DAI
"RTN","PSON52",68,0)
 I $G(PSOX("CHCS NUMBER"))'="" S $P(^PSRX(PSOX("IRXN"),"EXT"),"^")=$G(PSOX("CHCS NUMBER"))
"RTN","PSON52",69,0)
 I $G(PSOX("EXTERNAL SYSTEM"))'="" S $P(^PSRX(PSOX("IRXN"),"EXT"),"^",2)=$G(PSOX("EXTERNAL SYSTEM"))
"RTN","PSON52",70,0)
 I $G(PSOX("NEWCOPAY")) S ^PSRX(PSOX("IRXN"),"IB")=$G(PSOX("NEWCOPAY"))
"RTN","PSON52",71,0)
 ;Next line, set SC question based on Copay status?
"RTN","PSON52",72,0)
IBQ ;I $G(PSOBILL)=2 S ^PSRX(PSOX("IRXN"),"IBQ")=$S($G(PSOX("NEWCOPAY")):0,1:1)
"RTN","PSON52",73,0)
 N PSOSCFLD S PSOSCFLD=$S(PSOSCP'="":$G(PSOANSQ("SC")),1:"")_"^"_$G(PSOANSQ("MST"))_"^"_$G(PSOANSQ("VEH"))_"^"_$G(PSOANSQ("RAD"))_"^"_$G(PSOANSQ("PGW"))_"^"_$G(PSOANSQ("HNC"))_"^"_$G(PSOANSQ("CV"))_"^"_$G(PSOANSQ("SHAD"))
"RTN","PSON52",74,0)
 I PSOSCP<50&($TR(PSOSCFLD,"^")'="")&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)'=1) D
"RTN","PSON52",75,0)
 . S ^PSRX(PSOX("IRXN"),"IBQ")=PSOSCFLD K PSOSCFLD  ;don't set if SC % is null or 0, just set it in ICD node
"RTN","PSON52",76,0)
 D ICD^PSODIAG
"RTN","PSON52",77,0)
 D:$$SWSTAT^IBBAPI() GACT^PSOPFSU0(PSOX("IRXN"),0)
"RTN","PSON52",78,0)
 K PSOANSQ,PSOANSQD,PSOX("NEWCOPAY")
"RTN","PSON52",79,0)
 L -^PSRX("B",PSOX("IRXN"))
"RTN","PSON52",80,0)
 Q
"RTN","PSON52",81,0)
 ;
"RTN","PSON52",82,0)
ACLOG ;activity log (digitally signed CS orders)
"RTN","PSON52",83,0)
 N DTTM,CNT,OCNT,XX
"RTN","PSON52",84,0)
 D NOW^%DTC S DTTM=%
"RTN","PSON52",85,0)
 S CNT=0 F XX=0:0 S XX=$O(^PSRX(PSOX("IRXN"),"A",XX)) Q:'XX  S CNT=XX
"RTN","PSON52",86,0)
 S OCNT=CNT
"RTN","PSON52",87,0)
 I $G(PSOCSP("NAME"))'=PSODRUG("NAME") S CNT=CNT+1,^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^NAME: "_PSOCSP("NAME")
"RTN","PSON52",88,0)
 S XX=0 F  S XX=$O(PSOCSP("DOSE",XX)) Q:'XX  I PSOCSP("DOSE",XX)'=$G(PSONEW("DOSE",XX)) D
"RTN","PSON52",89,0)
 .S CNT=CNT+1,^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^DOSAGE: "_PSOCSP("DOSE",XX)
"RTN","PSON52",90,0)
 S XX=0 F  S XX=$O(PSOCSP("DOSE ORDERED",XX)) Q:'XX  I PSOCSP("DOSE ORDERED",XX)'=$G(PSONEW("DOSE ORDERED",XX)) D
"RTN","PSON52",91,0)
 .S CNT=CNT+1,^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^DISPENSE UNITS: "_PSOCSP("DOSE ORDERED",XX)
"RTN","PSON52",92,0)
 I PSOCSP("ISSUE DATE")'=PSONEW("ISSUE DATE") S CNT=CNT+1,^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^ISSUE DATE: "_$$FMTE^XLFDT(PSOCSP("ISSUE DATE"))
"RTN","PSON52",93,0)
 I PSOCSP("DAYS SUPPLY")'=PSONEW("DAYS SUPPLY") S CNT=CNT+1,^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^DAYS SUPPLY: "_PSOCSP("DAYS SUPPLY")
"RTN","PSON52",94,0)
 I PSOCSP("QTY")'=PSONEW("QTY") S CNT=CNT+1,^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^QTY: "_PSOCSP("QTY")
"RTN","PSON52",95,0)
 I PSOCSP("# OF REFILLS")'=PSONEW("# OF REFILLS") S CNT=CNT+1,^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^# OF REFILLS: "_PSOCSP("# OF REFILLS")
"RTN","PSON52",96,0)
 I '$$SUBSCRIB^ORDEA($P(OR0,"^"),PSOX("IRXN")) S CNT=CNT+1,^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^ORDER DEA ARCHIVE INFO file entry failure"
"RTN","PSON52",97,0)
 I OCNT'=CNT S ^PSRX(PSOX("IRXN"),"A",0)="^52.3DA^"_CNT_"^"_CNT
"RTN","PSON52",98,0)
 Q
"RTN","PSON52",99,0)
 ;
"RTN","PSON52",100,0)
PS55 ;
"RTN","PSON52",101,0)
 L +^PS(55,PSODFN,"P"):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
"RTN","PSON52",102,0)
 S:'$D(^PS(55,PSODFN,"P",0)) ^(0)="^55.03PA^^"
"RTN","PSON52",103,0)
 F PSOX1=$P(^PS(55,PSODFN,"P",0),"^",3):1 Q:'$D(^PS(55,PSODFN,"P",PSOX1))
"RTN","PSON52",104,0)
 S PSOX("55 IEN")=PSOX1
"RTN","PSON52",105,0)
 S ^PS(55,PSODFN,"P",PSOX1,0)=PSOX("IRXN"),$P(^PS(55,PSODFN,"P",0),"^",3,4)=PSOX1_"^"_($P(^PS(55,PSODFN,"P",0),"^",4)+1)
"RTN","PSON52",106,0)
 S ^PS(55,PSODFN,"P","A",PSONEW("STOP DATE"),PSOX("IRXN"))=""
"RTN","PSON52",107,0)
PS55X L -^PS(55,PSODFN,"P")
"RTN","PSON52",108,0)
 K PSOX1
"RTN","PSON52",109,0)
 Q
"RTN","PSON52",110,0)
DIK ;
"RTN","PSON52",111,0)
 I $D(^XUSEC("PSORPH",DUZ)) S DA=PSOX("IRXN"),DIE=52,DR="41////"_PSOCOU_";S:'X Y=""@1"";42////"_PSOCOUU_";@1" D ^DIE K DIE,DR
"RTN","PSON52",112,0)
 K DIK,DA S DIK="^PSRX(",DA=PSOX("IRXN") D IX1^DIK K DIK
"RTN","PSON52",113,0)
 S DA=PSOX("IRXN") D ORC^PSORN52C
"RTN","PSON52",114,0)
 Q
"RTN","PSON52",115,0)
FINISH ;
"RTN","PSON52",116,0)
ANQ I $G(ANQDATA)]"" D NOW^%DTC G:$D(^PS(52.52,"B",%)) ANQ D
"RTN","PSON52",117,0)
 .K DD,DO S DIC="^PS(52.52,",DIC(0)="L",DLAYGO=52.52,X=% D FILE^DICN K DIC,DLAYGO,DD,DO
"RTN","PSON52",118,0)
 .S ^PS(52.52,+Y,0)=$P(Y,"^",2)_"^"_PSOX("IRXN")_"^"_ANQDATA,^PS(52.52,"A",PSOX("IRXN"),+Y)="" K ANQDATA,X,Y,%,ANQREM
"RTN","PSON52",119,0)
 ;
"RTN","PSON52",120,0)
 N PSOTFIN
"RTN","PSON52",121,0)
 I $D(PSOX("NOPSDRPH"))!('$D(^XUSEC("PSORPH",DUZ))) S PSOTFIN="",PSOTFIN=$$TECH2^PSODGDGP(PSOX("IRXN"),PSODFN,DUZ,.PSOX)
"RTN","PSON52",122,0)
 I $D(PSOX("NOPSDRPH"))!('$D(^XUSEC("PSORPH",DUZ))) G FINISHP:$G(PSOTFIN)=1 G FINISHX:$G(PSOTFIN)=2
"RTN","PSON52",123,0)
 ;
"RTN","PSON52",124,0)
 I PSOX("FILL DATE")>DT,$P(PSOPAR,"^",6) S DA=PSOX("IRXN"),RXFL(PSOX("IRXN"))=0 D SUS^PSORXL K DA G FINISHX
"RTN","PSON52",125,0)
 ;
"RTN","PSON52",126,0)
 ; - Calling ECME for claims generation and transmission / REJECT handling
"RTN","PSON52",127,0)
 N ACTION,PSOERX
"RTN","PSON52",128,0)
 S PSOERX=PSOX("IRXN")
"RTN","PSON52",129,0)
 I $$SUBMIT^PSOBPSUT(PSOERX,0) D  I ACTION="Q"!(ACTION="^") Q
"RTN","PSON52",130,0)
 . S ACTION="" D ECMESND^PSOBPSU1(PSOERX,0,"","OF")
"RTN","PSON52",131,0)
 . ; Quit if there is an unresolved Tricare/CHAMPVA non-billable reject code, PSO*7*358
"RTN","PSON52",132,0)
 . I $$PSOET^PSOREJP3(PSOERX,0) S ACTION="Q" Q
"RTN","PSON52",133,0)
 . I $$FIND^PSOREJUT(PSOERX,0) D
"RTN","PSON52",134,0)
 . . S ACTION=$$HDLG^PSOREJU1(PSOERX,0,"79,88","OF","IOQ","Q")
"RTN","PSON52",135,0)
 . I $$STATUS^PSOBPSUT(PSOERX,0)="E PAYABLE" D
"RTN","PSON52",136,0)
 . . D SAVNDC^PSSNDCUT(+$$GET1^DIQ(52,PSOERX,6,"I"),$G(PSOSITE),$$GETNDC^PSONDCUT(PSOERX,0))
"RTN","PSON52",137,0)
 ;
"RTN","PSON52",138,0)
FINISHP ;
"RTN","PSON52",139,0)
 I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=PSOX("IRXN")_",",RXFL(PSOX("IRXN"))=0 G FINISHX
"RTN","PSON52",140,0)
 F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1  S PSOX2=PSOX1
"RTN","PSON52",141,0)
 I $L(PSORX("PSOL",PSOX2))+$L(PSOX("IRXN"))<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_PSOX("IRXN")_","
"RTN","PSON52",142,0)
 E  S PSORX("PSOL",PSOX2+1)=PSOX("IRXN")_","
"RTN","PSON52",143,0)
 S RXFL(PSOX("IRXN"))=0
"RTN","PSON52",144,0)
FINISHX ;call to build Rx array for bingo board
"RTN","PSON52",145,0)
 I $G(PSORX("MAIL/WINDOW"))["W" S BINGCRT=1,BINGRTE="W",BBFLG=1 D BBRX^PSORN52C
"RTN","PSON52",146,0)
 K PSOX1,PSOX2
"RTN","PSON52",147,0)
 K ^TMP("PSODGI",$J),^TMP("PSOSER",$J),^TMP("PSOSERS",$J),^TMP("PSODGS",$J),^TMP("PSOTDD",$J),^TMP("PSODOSF",$J)
"RTN","PSON52",148,0)
 Q
"RTN","PSON52",149,0)
EOJ ;
"RTN","PSON52",150,0)
 ;B xref locked in routine PSONRXN
"RTN","PSON52",151,0)
 L -^PSRX("B",PSOX("IRXN")) K OTHDOS,DA,PSON52,PSOPRC,RTE,SCH,PSOX("INS"),PSONEW("INS"),PSORXED("INS"),PSONEW("ENT"),PSORXED("ENT"),OLENT
"RTN","PSON52",152,0)
 D PSOUL^PSSLOCK(PSOX("IRXN"))
"RTN","PSON52",153,0)
 Q
"RTN","PSON52",154,0)
 ;
"RTN","PSON52",155,0)
 ;;PSOX("SIG");;SIG;;1
"RTN","PSON52",156,0)
DD ;;PSOX("RX #");;0;;1
"RTN","PSON52",157,0)
 ;;PSOX("ISSUE DATE");;0;;13
"RTN","PSON52",158,0)
 ;;PSODFN;;0;;2
"RTN","PSON52",159,0)
 ;;PSOX("PATIENT STATUS");;0;;3
"RTN","PSON52",160,0)
 ;;PSOX("PROVIDER");;0;;4
"RTN","PSON52",161,0)
 ;;PSOX("CLINIC");;0;;5
"RTN","PSON52",162,0)
 ;;PSODRUG("IEN");;0;;6
"RTN","PSON52",163,0)
 ;;PSODRUG("TRADE NAME");;TN;;1
"RTN","PSON52",164,0)
 ;;PSOX("QTY");;0;;7
"RTN","PSON52",165,0)
 ;;PSOX("DAYS SUPPLY");;0;;8
"RTN","PSON52",166,0)
 ;;PSOX("# OF REFILLS");;0;;9
"RTN","PSON52",167,0)
 ;;PSOX("COPIES");;0;;18
"RTN","PSON52",168,0)
 ;;PSOX("MAIL/WINDOW");;0;;11
"RTN","PSON52",169,0)
 ;;PSOX("REMARKS");;3;;7
"RTN","PSON52",170,0)
 ;;PSOX("CLERK CODE");;0;;16
"RTN","PSON52",171,0)
 ;;PSODRUG("COST");;0;;17
"RTN","PSON52",172,0)
 ;;PSOSITE;;2;;9
"RTN","PSON52",173,0)
 ;;PSOX("LOGIN DATE");;2;;1
"RTN","PSON52",174,0)
 ;;PSOX("FILL DATE");;2;;2
"RTN","PSON52",175,0)
 ;;PSOX("PHARMACIST");;2;;3
"RTN","PSON52",176,0)
 ;;PSOX("LOT #");;2;;4
"RTN","PSON52",177,0)
 ;;PSOX("DISPENSED DATE");;2;;5
"RTN","PSON52",178,0)
 ;;PSOX("STOP DATE");;2;;6
"RTN","PSON52",179,0)
 ;;PSODRUG("NDC");;2;;7
"RTN","PSON52",180,0)
 ;;PSODRUG("DAW");;EPH;;1
"RTN","PSON52",181,0)
 ;;PSODRUG("MANUFACTURER");;2;;8
"RTN","PSON52",182,0)
 ;;PSOX("EXPIRATION DATE");;2;;11
"RTN","PSON52",183,0)
 ;;PSOX("GENERIC PROVIDER");;2;;12
"RTN","PSON52",184,0)
 ;;PSOX("RELEASED DATE/TIME");;2;;13
"RTN","PSON52",185,0)
 ;;PSOX("METHOD OF PICK-UP");;MP;;1
"RTN","PSON52",186,0)
 ;;PSOX("STATUS");;STA;;1
"RTN","PSON52",187,0)
 ;;PSOX("LAST DISPENSED DATE");;3;;1
"RTN","PSON52",188,0)
 ;;PSOX("NEXT POSSIBLE REFILL");;3;;2
"RTN","PSON52",189,0)
 ;;PSOX("COSIGNING PROVIDER");;3;;3
"RTN","PSON52",190,0)
 ;;PSOX("TYPE OF RX");;TYPE;;1
"RTN","PSON52",191,0)
 ;;PSOX("SAND");;SAND;;1
"RTN","PSON52",192,0)
 ;;PSOX("POE");;POE;;1
"RTN","PSON52",193,0)
 ;;PSOX("INS");;INS;;1
"RTN","PSONFI")
0^32^B8543831^B9036524
"RTN","PSONFI",1,0)
PSONFI ;BIR/MHA - dispense drug/orderable item text display ;09/13/00
"RTN","PSONFI",2,0)
 ;;7.0;OUTPATIENT PHARMACY;**46,94,131,225,391**;DEC 1997;Build 13
"RTN","PSONFI",3,0)
 ;External reference to PSSDIN is supported by DBIA 3166
"RTN","PSONFI",4,0)
 ;External reference to ^PS(50.606 is supported by DBIA 2174
"RTN","PSONFI",5,0)
 ;External reference to ^PS(50.7 is supported by DBIA 2223
"RTN","PSONFI",6,0)
 ;External reference to ^PSDRUG( is supported by DBIA 221
"RTN","PSONFI",7,0)
 ;
"RTN","PSONFI",8,0)
NFI ;display restriction/guidelines
"RTN","PSONFI",9,0)
 D EN^PSSDIN(PSODRUG("OI"),PSODRUG("IEN")) S NFI=$$PROMPT^PSSDIN
"RTN","PSONFI",10,0)
 I NFI]"","ODY"[NFI D TD^PSONFI S DIR(0)="E" D ^DIR K DIR
"RTN","PSONFI",11,0)
 K NFI Q
"RTN","PSONFI",12,0)
DDTX ;Display drug text for the hidden action DIN
"RTN","PSONFI",13,0)
 N OI,DD
"RTN","PSONFI",14,0)
 S:$D(PSODRUG("OI")) OI=PSODRUG("OI") S:$D(PSODRUG("IEN")) DD=PSODRUG("IEN")
"RTN","PSONFI",15,0)
 I $G(OI),$G(DD) G 1
"RTN","PSONFI",16,0)
 I $D(PSORNSV),$G(PSORNSV)]"" S OI=+$P(OR0,"^",8),DD=+$P(OR0,"^",9) G 1
"RTN","PSONFI",17,0)
 S OI=+RXOR,DD=+$P(RX0,"^",6)
"RTN","PSONFI",18,0)
1 S OI=$S($G(OI):OI,1:""),DD=$S($G(DD):DD,1:"")
"RTN","PSONFI",19,0)
 D EN^PSSDIN(OI,DD)
"RTN","PSONFI",20,0)
 N N1,N2,N3,N4,TX,NX S NX="PSSDIN"
"RTN","PSONFI",21,0)
 W @IOF,!!,"Drug restriction/guideline info:",!!
"RTN","PSONFI",22,0)
 W !,"Orderable Item: "_$P(^PS(50.7,OI,0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")_$S($P(^PS(50.7,OI,0),"^",12):" ***(N/F)***",1:""),!!
"RTN","PSONFI",23,0)
 I $O(^TMP("PSSDIN",$J,"OI",0)) S N1="OI" D TXD
"RTN","PSONFI",24,0)
 W:'$O(^TMP("PSSDIN",$J,"OI",0)) ?5,"No information available ",!!
"RTN","PSONFI",25,0)
 I $G(DD),$D(^PSDRUG(DD,0)) W !,"Drug: "_$P(^PSDRUG(DD,0),"^")_$S($P(^PSDRUG(DD,0),"^",9):" ***(N/F)***",1:""),!! D
"RTN","PSONFI",26,0)
 .I $O(^TMP("PSSDIN",$J,"DD",0)) S N1="DD" D TXD
"RTN","PSONFI",27,0)
 .W:'$O(^TMP("PSSDIN",$J,"DD",0)) ?5,"No information available ",!!
"RTN","PSONFI",28,0)
HLD K DIR S DIR(0)="E" D ^DIR K DIR
"RTN","PSONFI",29,0)
 Q
"RTN","PSONFI",30,0)
DIN(OI,DD) ;Setup DIN indicator
"RTN","PSONFI",31,0)
 S (NFIO,NFID)=""
"RTN","PSONFI",32,0)
 I $D(OI),$G(OI) S:$P($G(^PS(50.7,OI,0)),"^",12) NFIO=" ***(N/F)***"
"RTN","PSONFI",33,0)
 I $D(DD),$G(DD) S:$P($G(^PSDRUG(DD,0)),"^",9) NFID=" ***(N/F)***"
"RTN","PSONFI",34,0)
 D EN^PSSDIN(OI,DD)
"RTN","PSONFI",35,0)
 S:$O(^TMP("PSSDIN",$J,"OI",0)) NFIO=NFIO_" <DIN>"
"RTN","PSONFI",36,0)
 S:$O(^TMP("PSSDIN",$J,"DD",0)) NFID=NFID_" <DIN>"
"RTN","PSONFI",37,0)
 K ^TMP("PSSDIN",$J) Q
"RTN","PSONFI",38,0)
 Q
"RTN","PSONFI",39,0)
RV ;reverse video
"RTN","PSONFI",40,0)
 I $G(PKID),$G(PKIE)]"" D CNTRL^VALM10(1,1,$L(PKIE),IORVON,IORVOFF,0)
"RTN","PSONFI",41,0)
 D:$G(NFIO) CNTRL^VALM10(+NFIO,$P(NFIO,",",2),5,IORVON,IORVOFF,0)
"RTN","PSONFI",42,0)
 D:$G(NFID) CNTRL^VALM10(+NFID,$P(NFID,",",2),5,IORVON,IORVOFF,0)
"RTN","PSONFI",43,0)
 K NFIO,NFID,PKID
"RTN","PSONFI",44,0)
 ;- Reverses video for the words "Flagged" and "Unflagged"
"RTN","PSONFI",45,0)
 N L
"RTN","PSONFI",46,0)
 F L=1:1:VALMCNT D
"RTN","PSONFI",47,0)
 . D:$D(FLAGLINE(L)) CNTRL^VALM10(L,1,FLAGLINE(L),IORVON,IORVOFF,0)
"RTN","PSONFI",48,0)
 Q
"RTN","PSONFI",49,0)
 ;
"RTN","PSONFI",50,0)
TD N N1,N2,N3,N4,TX,NX S NX="PSSDIN"
"RTN","PSONFI",51,0)
 W @IOF
"RTN","PSONFI",52,0)
 I NFI="O" D OIT
"RTN","PSONFI",53,0)
 I NFI="D" D DDT
"RTN","PSONFI",54,0)
 I NFI="Y" D DDT,OIT
"RTN","PSONFI",55,0)
 Q
"RTN","PSONFI",56,0)
OIT ;
"RTN","PSONFI",57,0)
 S N1="OI",TX="Orderable Item Text:" D TXT
"RTN","PSONFI",58,0)
 Q
"RTN","PSONFI",59,0)
DDT ;
"RTN","PSONFI",60,0)
 S N1="DD",TX="Dispense Drug Text:" D TXT
"RTN","PSONFI",61,0)
 Q
"RTN","PSONFI",62,0)
TXT ;
"RTN","PSONFI",63,0)
 W !,TX
"RTN","PSONFI",64,0)
TXD K ^UTILITY($J,"W")
"RTN","PSONFI",65,0)
 S N2="" F  S N2=$O(^TMP(NX,$J,N1,N2)) Q:'N2!($D(DIRUT))  D
"RTN","PSONFI",66,0)
 .S N3="" F  S N3=$O(^TMP(NX,$J,N1,N2,N3)) Q:'N3!($D(DIRUT))  D
"RTN","PSONFI",67,0)
 ..S N4="" F  S N4=$O(^TMP(NX,$J,N1,N2,N3,N4)) Q:'N4!($D(DIRUT))  D
"RTN","PSONFI",68,0)
 ...W !?5,^TMP(NX,$J,N1,N2,N3,N4) I $Y>20 W ! D HLD Q:$D(DIRUT)  W @IOF
"RTN","PSONFI",69,0)
 W ! K ^UTILITY($J,"W")
"RTN","PSONFI",70,0)
 Q
"RTN","PSOORED4")
0^38^B54971624^B52076927
"RTN","PSOORED4",1,0)
PSOORED4 ;BIR/SAB - Edit front door dosing ;07/13/00
"RTN","PSOORED4",2,0)
 ;;7.0;OUTPATIENT PHARMACY;**46,91,78,99,111,117,133,159,148,251,391**;DEC 1997;Build 13
"RTN","PSOORED4",3,0)
 ;External reference ^PS(51 supported by DBIA 2224
"RTN","PSOORED4",4,0)
 ;External reference to PS(51.2 supported by DBIA 2226
"RTN","PSOORED4",5,0)
 ;External reference to PS(51.1 supported by DBIA 2225
"RTN","PSOORED4",6,0)
 ;External reference to $$DS^PSSDSAPI supported by DBIA 5424
"RTN","PSOORED4",7,0)
 ;called from psoornew
"RTN","PSOORED4",8,0)
 ;
"RTN","PSOORED4",9,0)
DOSE(PSORXED) ;
"RTN","PSOORED4",10,0)
 I '$G(PSODRUG("IEN")) W !,"DRUG NAME REQUIRED!" D 2^PSOORNW1 I '$G(PSODRUG("IEN")) S VALMSG="No Dispense Drug Selected" Q
"RTN","PSOORED4",11,0)
 K ROU,STRE,UNITN,PSODOSE M PSODOSE=PSORXED
"RTN","PSOORED4",12,0)
 D KV K FIELD,DOSEOR,DUPD,X,Y,UNITS S ENT=1,OLENT=PSORXED("ENT")
"RTN","PSOORED4",13,0)
ASK I $G(ORD) W !!,"Possible SIG: " D
"RTN","PSOORED4",14,0)
 .;Coded only for outside orders with no Patient Instructions
"RTN","PSOORED4",15,0)
 .I $O(SIG(""))="",$G(ORD),$P($G(^PS(52.41,ORD,"EXT")),"^")'="" D SIGS^PSOHCPRS
"RTN","PSOORED4",16,0)
 .S INST=0 F  S INST=$O(SIG(INST)) Q:'INST  S MIG=SIG(INST) D
"RTN","PSOORED4",17,0)
 ..F SG=1:1:$L(MIG," ") W:$X+$L($P(MIG," ",SG)_" ")>IOM !?14 W $P(MIG," ",SG)_" "
"RTN","PSOORED4",18,0)
 K SG,INST,MIG
"RTN","PSOORED4",19,0)
 S ROU="PSOORED4",II=ENT D ASK^PSOBKDED K ROU,II I $G(JUMP) K JUMP G JUMP
"RTN","PSOORED4",20,0)
 G:$D(DIRUT) EXQ
"RTN","PSOORED4",21,0)
 ;
"RTN","PSOORED4",22,0)
 I $G(VERB)]"" S PSORXED("VERB",ENT)=VERB G DUPD
"RTN","PSOORED4",23,0)
VER D VER^PSOOREDX I X[U,$L(X)>1 S FIELD="VER" G JUMP
"RTN","PSOORED4",24,0)
 G:$D(DTOUT)!($D(DUOUT)) EXQ
"RTN","PSOORED4",25,0)
 I X="@" K PSORXED("VERB",ENT),VERB G DUPD
"RTN","PSOORED4",26,0)
 S:X'="" (PSORXED("VERB",ENT),VERB)=X
"RTN","PSOORED4",27,0)
DUPD ;
"RTN","PSOORED4",28,0)
 I $G(PSORXED("DOSE",ENT))'?.N&($G(PSORXED("DOSE",ENT))'?.N1".".N)!'DOSE("LD") K PSORXED("DOSE ORDERED",ENT),DUPD G NOU1
"RTN","PSOORED4",29,0)
 D DUPD^PSOOREDX
"RTN","PSOORED4",30,0)
 S DIR("B")=$S($G(PSORXED("DOSE ORDERED",ENT))]"":PSORXED("DOSE ORDERED",ENT),1:1) S:$E($G(DIR("B")),1)="." DIR("B")="0"_$G(DIR("B")) K:DIR("B")="" DIR("B")
"RTN","PSOORED4",31,0)
 D ^DIR I X[U,$L(X)>1 S FIELD="DUPD" G JUMP
"RTN","PSOORED4",32,0)
 G:$D(DTOUT)!($D(DUOUT)) EXQ
"RTN","PSOORED4",33,0)
 I X="@"!(X=0) W !,"Dispense Units Per Dose is Required!!",! G DUPD
"RTN","PSOORED4",34,0)
 D STR^PSOOREDX
"RTN","PSOORED4",35,0)
NOU1 G:'$G(PSORXED("DOSE ORDERED",ENT)) RTE
"RTN","PSOORED4",36,0)
 D CNON^PSOORED3
"RTN","PSOORED4",37,0)
 N PSONDEF
"RTN","PSOORED4",38,0)
 I $G(NOUN)]"" S PSORXED("NOUN",ENT)=NOUN
"RTN","PSOORED4",39,0)
NOU D NOU^PSOOREDX I X[U,$L(X)>1 S FIELD="NOU" G JUMP
"RTN","PSOORED4",40,0)
 G:$D(DTOUT)!($D(DUOUT)) EXQ
"RTN","PSOORED4",41,0)
 I X="@" K PSORXED("NOUN",ENT),NOUN G RTE
"RTN","PSOORED4",42,0)
 I X'="",$G(PSONDEF)="" S NOUN=X
"RTN","PSOORED4",43,0)
 I X'="",$G(PSONDEF)'=X S NOUN=X
"RTN","PSOORED4",44,0)
 S:X'="" PSORXED("NOUN",ENT)=X
"RTN","PSOORED4",45,0)
 ;
"RTN","PSOORED4",46,0)
RTE K JUMP S ROU="PSOORED4" D RTE^PSOBKDED K ROU
"RTN","PSOORED4",47,0)
 I $G(JUMP) K JUMP G JUMP
"RTN","PSOORED4",48,0)
 G:$D(DTOUT)!($D(DUOUT)) EXQ
"RTN","PSOORED4",49,0)
 ;
"RTN","PSOORED4",50,0)
SCH D SCH^PSOBKDED I X[U,$L(X)>1 S FIELD="SCH" G JUMP
"RTN","PSOORED4",51,0)
 G:$D(DTOUT)!($D(DUOUT)) EXQ
"RTN","PSOORED4",52,0)
 S SCH=Y D SCH^PSOSIG I $G(SCH)']"" G SCH
"RTN","PSOORED4",53,0)
 S PSORXED("SCHEDULE",ENT)=SCH W " ("_SCHEX_")" K SCH,SCHEX,X,Y,PSOSCH
"RTN","PSOORED4",54,0)
 S:PSORXED("ENT")<ENT PSORXED("ENT")=ENT
"RTN","PSOORED4",55,0)
 ;
"RTN","PSOORED4",56,0)
DUR D KV K EXP S DIR(0)="52.0113,4",DIR("A")="LIMITED DURATION (IN DAYS, HOURS OR MINUTES)"
"RTN","PSOORED4",57,0)
 S DIR("B")=$S($G(PSORXED("DURATION",ENT))]"":PSORXED("DURATION",ENT),1:"") K:DIR("B")="" DIR("B")
"RTN","PSOORED4",58,0)
 D ^DIR I X[U,$L(X)>1 S FIELD="DUR" G JUMP
"RTN","PSOORED4",59,0)
 G:$D(DTOUT)!($D(DUOUT)) EXQ
"RTN","PSOORED4",60,0)
 D DUR1^PSOOREDX
"RTN","PSOORED4",61,0)
 ;
"RTN","PSOORED4",62,0)
CON D CON^PSOOREDX I X[U,$L(X)>1 S FIELD="CON" G JUMP
"RTN","PSOORED4",63,0)
 G:$D(DTOUT)!($D(DUOUT)) EXQ
"RTN","PSOORED4",64,0)
 I X="@",$G(PSORXED("CONJUNCTION",ENT))="" W !,?10,"Invalid Entry - nothing to delete!!" G CON
"RTN","PSOORED4",65,0)
 S:X'=""&(X'="@") PSORXED("CONJUNCTION",ENT)=Y
"RTN","PSOORED4",66,0)
 I X="@",$D(PSORXED("CONJUNCTION",ENT)) D CON1^PSOOREDX G:$D(DIRUT) EXQ G:'Y CON N CKX S CKX=1 D UPD^PSOOREDX G CON
"RTN","PSOORED4",67,0)
 ;
"RTN","PSOORED4",68,0)
 N PSODLBD4 S PSOSAVX=X,PSODLBD4=1,PSOEDDOS=1
"RTN","PSOORED4",69,0)
 I $G(PSORXED("CONJUNCTION",ENT))]"" D:$$DS^PSSDSAPI DCHK1^PSODOSUT S PSOCKCON=1 G:$G(PSONEW("DFLG")) EX S ENT=ENT+1 K DIR G ASK
"RTN","PSOORED4",70,0)
 E  D  I $$DS^PSSDSAPI,$$DCHK^PSODOSUT S PSORX("DFLG")=1,PSONEW("DFLG")=1 G EX
"RTN","PSOORED4",71,0)
 . Q:$G(PSORXED)!$G(PSOEDDOS)
"RTN","PSOORED4",72,0)
 . K PSOCKCON
"RTN","PSOORED4",73,0)
 I PSOSAVX="",$G(PSORXED) K PSOCKCON,PSOEDDOS
"RTN","PSOORED4",74,0)
 K PSOSAVX
"RTN","PSOORED4",75,0)
 ;
"RTN","PSOORED4",76,0)
 S X=$G(PSORXED("INS")) D SIG^PSOHELP S:$G(INS1)]"" PSORXED("SIG")=$E(INS1,2,9999999)
"RTN","PSOORED4",77,0)
 D EN^PSOFSIG(.PSORXED),VERI I $G(CKX),'$G(PSOSIGFL) D MP1 K CKX
"RTN","PSOORED4",78,0)
 I $G(PSOSIGFL)=1 D  I '$G(PSOSIGFL) Q
"RTN","PSOORED4",79,0)
 .I $D(OR0),$P(OR0,"^",24)=1 S VALMSG="Digitally Signed Order - No such changes allowed." K PSORXED,PSOSIGFL M PSORXED=PSODOSE D EN^PSOFSIG(.PSORXED) D  Q
"RTN","PSOORED4",80,0)
 ..I $D(PSOBDR) K PSODRUG M PSODRUG=PSOBDR K PSOBDR,PSOBDRG
"RTN","PSOORED4",81,0)
 .S PSORXED("ENT")=ENT,SIGOK=1,VALMSG="This change will create a new prescription!",NCPDPFLG=1
"RTN","PSOORED4",82,0)
 K QTYHLD S:$G(PSORXED("QTY")) QTYHLD=PSORXED("QTY") D QTY^PSOSIG(.PSORXED) I $G(PSORXED("QTY")) S QTY=1
"RTN","PSOORED4",83,0)
 I $G(QTYHLD),'$G(PSORXED("QTY")) S PSORXED("QTY")=QTYHLD
"RTN","PSOORED4",84,0)
 K QTYHLD
"RTN","PSOORED4",85,0)
 I '$G(PSORXED("QTY")),$P(OR0,"^",10) S PSORXED("QTY")=$P(OR0,"^",10)
"RTN","PSOORED4",86,0)
EX ;
"RTN","PSOORED4",87,0)
 K PSOBDR,PSOBDRG,PSOSCH,DUPD,STRE,UNITN,SCH,VERB,NOUN,DOSEOR,RTE,DUR,X,Y,ENTS,PSODOSE,OLENT,FIELD,FLDNM,AR,NM,ENT,STRE,UNITN,PSODOSE,ERTE,ROU
"RTN","PSOORED4",88,0)
KV K DTOUT,DUOUT,DIR,DIRUT
"RTN","PSOORED4",89,0)
 Q
"RTN","PSOORED4",90,0)
EXQ ;
"RTN","PSOORED4",91,0)
 K PSORXED,PSOSIGFL M PSORXED=PSODOSE D EN^PSOFSIG(.PSORXED) D MP1
"RTN","PSOORED4",92,0)
 I $D(PSOBDR) M PSODRUG=PSOBDR K PSOBDR,PSOBDRG
"RTN","PSOORED4",93,0)
 G EX Q
"RTN","PSOORED4",94,0)
MP1 D MP1^PSOOREDX
"RTN","PSOORED4",95,0)
 Q
"RTN","PSOORED4",96,0)
VERI ;checks for changes to dosing instructions
"RTN","PSOORED4",97,0)
 S ENTS=0
"RTN","PSOORED4",98,0)
 F I=0:0 S I=$O(PSORXED("DOSE",I)) Q:'I  S ENTS=$G(ENTS)+1
"RTN","PSOORED4",99,0)
 I ENTS<OLENT!(ENTS>OLENT) S PSOSIGFL=1 Q
"RTN","PSOORED4",100,0)
 F I=1:1:OLENT D
"RTN","PSOORED4",101,0)
 .I +PSODOSE("DOSE",I)'=$G(PSORXED("DOSE",I)) S PSOSIGFL=1
"RTN","PSOORED4",102,0)
 .I $G(PSODOSE("DURATION",I))]"" D
"RTN","PSOORED4",103,0)
 ..S DURATION=$S($E(PSODOSE("DURATION",I),1)'?.N:$E(PSODOSE("DURATION",I),2,99)_$E(PSODOSE("DURATION",I),1),1:PSODOSE("DURATION",I))
"RTN","PSOORED4",104,0)
 ..I +DURATION'=+$G(PSORXED("DURATION",I)) S PSOSIGFL=1
"RTN","PSOORED4",105,0)
 .I $G(PSODOSE("CONJUNCTION",I))'=$G(PSORXED("CONJUNCTION",I)) S PSOSIGFL=1
"RTN","PSOORED4",106,0)
 .I PSODOSE("ROUTE",I)'=$G(PSORXED("ROUTE",I)) S PSOSIGFL=1
"RTN","PSOORED4",107,0)
 .I PSODOSE("SCHEDULE",I)'=$G(PSORXED("SCHEDULE",I)) S PSOSIGFL=1
"RTN","PSOORED4",108,0)
 K DURATION Q
"RTN","PSOORED4",109,0)
JUMP ;jump to fields
"RTN","PSOORED4",110,0)
 I $L($E(X,2,99))<3 W !,"Field Name Must Be At Least 3 Characters in Length",! G @FIELD
"RTN","PSOORED4",111,0)
 D FNM^PSOOREDX
"RTN","PSOORED4",112,0)
 I FLDNM']"" K X,NM,FLDNM W !,"INVALID FIELD NAME.  PLEASE TRY AGAIN!",! G @FIELD
"RTN","PSOORED4",113,0)
 F AR=1:1:PSORXED("ENT") W !,AR_". "_$P(FLDNM,"^",2)_": "_$S(NM="ROU"&($G(PSORXED($P(FLDNM,"^"),AR))):$P(^PS(51.2,PSORXED($P(FLDNM,"^"),AR),0),"^"),1:$G(PSORXED($P(FLDNM,"^"),AR))) S AR1=AR
"RTN","PSOORED4",114,0)
 D KV S DIR("A",1)="* Indicates which fields will create a New Order",DIR("A")="Select Field to Edit by number",DIR(0)="NO^1:"_AR1 D ^DIR G:$D(DIRUT) @FIELD
"RTN","PSOORED4",115,0)
 D JFN^PSOOREDX G:FLDNM="" @FIELD G @FLDNM
"RTN","PSOORED4",116,0)
 G EX
"RTN","PSOORED4",117,0)
 Q
"RTN","PSOORED4",118,0)
HLP ;help text for med route
"RTN","PSOORED4",119,0)
 D FULL^VALM1 W !,"Please enter how patient will use the medication!"
"RTN","PSOORED4",120,0)
 S DIC=51.2,X="??",DIC(0)="M",DIC("S")="I $P(^PS(51.2,+Y,0),""^"",4)" D ^DIC K DIC,X,Y
"RTN","PSOORED4",121,0)
 Q
"RTN","PSOORED4",122,0)
SCHLP ;
"RTN","PSOORED4",123,0)
 D FULL^VALM1 W !,"You can choose an entry from the Administration Schedule File (#51.1),",!,"Medication Instruction File (#51) or enter free text."
"RTN","PSOORED4",124,0)
 W !,"The free text entry cannot contain more than 2 spaces or be greater than 20",!,"characters in length."
"RTN","PSOORED4",125,0)
 W ! S DIR(0)="S^A:Administration Schedule File;M:Medication Instruction File;B:Both;F:Free Text",DIR("B")="Both"
"RTN","PSOORED4",126,0)
 S DIR("A")="Do you want to list from" D ^DIR I Y="F"!($G(DIRUT)) K X,Y G X
"RTN","PSOORED4",127,0)
 S LBL=Y G @LBL
"RTN","PSOORED4",128,0)
A ;display 51.1 entries only
"RTN","PSOORED4",129,0)
B K X,Y,DIC S X="??",DIC="^PS(51.1,",DIC(0)="QES",DIC("W")="D DICW^PSOORED4",D="APPSJ" W ! D IX^DIC
"RTN","PSOORED4",130,0)
 K DIC,X I LBL="A"!($G(DTOUT)) K LBL G X
"RTN","PSOORED4",131,0)
 I Y=-1!($G(DUOUT)) K DIR,DTOUT,DUOUT S DIR(0)="Y",DIR("B")="No",DIR("A")="Do you want to continue with the Medication Instruction File"
"RTN","PSOORED4",132,0)
 D ^DIR I 'Y!($G(DTOUT)) K DIR,X,Y G X
"RTN","PSOORED4",133,0)
M K X,Y,DIC S DIC=51,X="??",DIC(0)="M" D ^DIC K DIC,X,Y,DTOUT,DUOUT,LBL
"RTN","PSOORED4",134,0)
X S DIR("?")="^D SCHLP^PSOORED4",DIR("A")="Schedule: ",DIR(0)="FA^1:20^I X[""""""""!(X?.E1C.E)!($A(X)=45)!($L(X,"" "")>3)!($L(X)>20)!($L(X)<1) K X"
"RTN","PSOORED4",135,0)
 S DIR("B")=$S($D(PSOSCH)&('$D(PSORXED("SCHEDULE",ENT))):PSOSCH,$G(PSORXED("SCHEDULE",ENT))]"":PSORXED("SCHEDULE",ENT),1:"") K:DIR("B")="" DIR("B")
"RTN","PSOORED4",136,0)
 Q
"RTN","PSOORED4",137,0)
DICW ;
"RTN","PSOORED4",138,0)
 S Z=$P(^PS(51.1,+Y,0),"^",5),Z=$S(Z="O":-1,Z="S":1,Z="R":-2,1:0) W:Z "  ",$S(Z>0:"SHIFT",Z=-2:"RANGE",1:"ONE-TIME")
"RTN","PSOORED4",139,0)
 I Z'<0,$D(PSJW),$D(^(PSJPP'="PSJ"+1,PSJW,0)),$P(^(0),"^",Z+2)]"" W "  ",$P(^(0),"^",Z+2)
"RTN","PSOORED4",140,0)
 ;Naked reference on DICW+2 is from DICW+1, ^PS(51.1,+Y,0)
"RTN","PSOORED4",141,0)
 Q
"RTN","PSOOREDT")
0^22^B72615864^B69885568
"RTN","PSOOREDT",1,0)
PSOOREDT ;BIR/SAB - edit orders from backdoor ;7/23/09 9:06am
"RTN","PSOOREDT",2,0)
 ;;7.0;OUTPATIENT PHARMACY;**4,20,27,37,57,46,78,102,104,119,143,148,260,281,304,289,298,379,377,391**;DEC 1997;Build 13
"RTN","PSOOREDT",3,0)
 ;External reference to ^PSDRUG supported by DBIA 221
"RTN","PSOOREDT",4,0)
 ;External reference to PSSLOCK supported by DBIA 2789
"RTN","PSOOREDT",5,0)
 ;External reference to ^VA(200 supported by DBIA 10060
"RTN","PSOOREDT",6,0)
SEL K PSOISLKD,PSOLOKED S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY D SVAL K PSOPLCK S VALMBCK="" Q
"RTN","PSOOREDT",7,0)
 K PSOPLCK D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) D UL^PSSLOCK(+$G(PSODFN)) D SVALO K PSOMSG S VALMBCK="" Q
"RTN","PSOOREDT",8,0)
 K PSOMSG S PSOLOKED=1
"RTN","PSOOREDT",9,0)
 S REF=0 S:$$LSTRFL^PSOBPSU1($P(PSOLST(ORN),"^",2)) REF=1  ;*377
"RTN","PSOOREDT",10,0)
 K PSORX("DFLG"),DIR,DUOUT,DIRUT S DIR("A")="Select fields by number"
"RTN","PSOOREDT",11,0)
 S DIR(0)="LO^1:"_$S($$STATUS^PSOBPSUT($P(PSOLST(ORN),"^",2))'="":21,$G(REF):20,1:19)
"RTN","PSOOREDT",12,0)
 D ^DIR I $D(DIRUT) K DIR,DIRUT,DTOUT S VALMBCK="" D UL K PSOLOKED Q
"RTN","PSOOREDT",13,0)
EDTSEL N VALMCNT K PSOISLKD,PSORX("DFLG"),PSOOIFLG,PSOMRFLG,DIR,DIRUT,DTOUT,DTOUT,ZONE S PSOQUIT=0,(PSOEDIT,PSORXED)=1 I +Y S FST=Y D HLDHDR^PSOLMUTL D  G EX ;PSO LM SELECT MENU protocol
"RTN","PSOOREDT",14,0)
 .I '$G(PSOLOKED) S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY D SVAL K PSOPLCK S VALMBCK="",(PSOISLKD,PSODE)=1 Q
"RTN","PSOOREDT",15,0)
 .I '$G(PSOLOKED) K PSOPLCK D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) D UL^PSSLOCK(+$G(PSODFN)) D SVALO K PSOMSG S VALMBCK="",(PSOISLKD,PSODE)=1 Q
"RTN","PSOOREDT",16,0)
 .K PSOMSG,PSOPLCK S (NEWEDT,PSOLOKED)=1 D EDT
"RTN","PSOOREDT",17,0)
 E  S VALMBCK="",PSODE=1
"RTN","PSOOREDT",18,0)
EX I $G(PSOISLKD)!($G(PSOQUIT)) D UL K PSOISLKD G EX2
"RTN","PSOOREDT",19,0)
 I '$G(PSOSIGFL),'$G(PSORXED("DFLG")) D UPDATE^PSOORED6 D LOG^PSORXED,POST^PSORXED G EX1
"RTN","PSOOREDT",20,0)
 I $G(PSOSIGFL)=1 D  Q:$G(PSORX("FN"))
"RTN","PSOOREDT",21,0)
 .N PSOTMP
"RTN","PSOOREDT",22,0)
 .S PSOTMP=$G(PSOFROM),PSOFROM="NEW"
"RTN","PSOOREDT",23,0)
 .S VALMSG="This change will create a new prescription!",NCPDPFLG=1
"RTN","PSOOREDT",24,0)
 .D EN^PSOORED1(.PSORXED)
"RTN","PSOOREDT",25,0)
 .I $G(PSORX("FN")) D  Q
"RTN","PSOOREDT",26,0)
 ..D ^PSOBUILD
"RTN","PSOOREDT",27,0)
 ..K QUIT,PSORX("DFLG"),FST,FLD,IEN,FLN,INCOM,PSOI,PSODRUG,PSOEDIT
"RTN","PSOOREDT",28,0)
 ..K PSORENW,PSOSIGFL,PSOOIFLG,PSOMRFLG,PSODIR,CHK,PSORX("SIG"),PSODE
"RTN","PSOOREDT",29,0)
 ..K PSOTRN,PSORX("EDIT"),PSORXED("FLD"),NEWEDT
"RTN","PSOOREDT",30,0)
 ..D EOJ^PSONEW
"RTN","PSOOREDT",31,0)
 ..D UL K PSOLOKED S VALMBCK="Q"
"RTN","PSOOREDT",32,0)
 .S PSOFROM=PSOTMP I PSOFROM="" K PSOFROM
"RTN","PSOOREDT",33,0)
 ;
"RTN","PSOOREDT",34,0)
EX1 I '$G(PSODE)!('$G(ZONE)) I $G(PSORENW("OIRXN")) D EN^PSOHLSN1(PSORENW("OIRXN"),"XX","","Order edited")
"RTN","PSOOREDT",35,0)
QUIT D UL K PSOLOKED D ^PSOBUILD,ACT^PSOORNE2 D:+^PSRX($P(PSOLST(ORN),"^",2),"STA")=5 EN^PSOCMOPC($P(PSOLST(ORN),"^",2))
"RTN","PSOOREDT",36,0)
 K:'$O(^PSRX($P(PSOLST(ORN),"^",2),1,0)) REF
"RTN","PSOOREDT",37,0)
EX2 S VALMBCK=$S($G(PSOQUIT):"R",$G(PSORX("FN")):"Q",$G(ZONE):"Q",1:"R")
"RTN","PSOOREDT",38,0)
 K PSORXED,FST,FLD,IEN,FLN,INCOM,PSOI,PSODRUG,PSOEDIT,PSORENW,PSOSIGFL,PSODIR,CHK,PSORX("SIG"),PSODE,PSOTRN,PSORX("DFLG"),RFED,ZONE,PSORX("EDIT"),PSOOIFLG,PSOMRFLG,SIG,QUIT,PSOQUIT
"RTN","PSOOREDT",39,0)
 K NEWEDT I $G(VALMBCK)="R" W ! D CLEAN^PSOVER1 H 2
"RTN","PSOOREDT",40,0)
 Q
"RTN","PSOOREDT",41,0)
 ;
"RTN","PSOOREDT",42,0)
EDT ; Rx Edit (Backdoor)
"RTN","PSOOREDT",43,0)
 K NCPDPFLG,PSOPKI,DEA
"RTN","PSOOREDT",44,0)
 S I=0 F  S I=$O(^PSRX($P(PSOLST(ORN),"^",2),1,I)) Q:'I  S PSORXED("RX1")=^PSRX($P(PSOLST(ORN),"^",2),1,I,0)
"RTN","PSOOREDT",45,0)
 ;*298 Track PI and Oth Lang PI
"RTN","PSOOREDT",46,0)
 S (RX0,PSORXED("RX0"))=^PSRX($P(PSOLST(ORN),"^",2),0),PSORXED("RX2")=$G(^(2)),PSORXED("RX3")=$G(^(3)),PSOSIG=$P(^("SIG"),"^"),PSOPINS=$G(^("INS")),PSOOINS=$G(^("INSS"))
"RTN","PSOOREDT",47,0)
 I '$D(PSODRUG) NEW PSOY S PSOY=$P(RX0,U,6),PSOY(0)=^PSDRUG(PSOY,0) D SET^PSODRG ; *298 moved this line from EDT+2  RX0 was not defined yet
"RTN","PSOOREDT",48,0)
 F FLD=1:1:$L(FST,",") Q:$P(FST,",",FLD)']""!($G(PSORXED("DFLG")))!($G(PSORX("DFLG")))  S FLN=+$P(FST,",",FLD) D
"RTN","PSOOREDT",49,0)
 .S PSORXED("DFLG")=0,(DA,PSORXED("IRXN"),PSORENW("OIRXN"))=$P(PSOLST(ORN),"^",2),RX0=^PSRX(PSORXED("IRXN"),0),PSOPKI=$P($G(^PSRX(PSORXED("IRXN"),"PKI")),"^") S:$G(PSOSIG)="" PSOSIG=$P(^("SIG"),"^")
"RTN","PSOOREDT",50,0)
 .;*298 Track PI and Oth Lang PI
"RTN","PSOOREDT",51,0)
 .S:$G(PSOPINS)="" PSOPINS=$G(^PSRX(DA,"INS")) S:$G(PSOOINS)="" PSOOINS=$G(^PSRX(DA,"INSS"))
"RTN","PSOOREDT",52,0)
 .I '$G(PSOSIGFL) D
"RTN","PSOOREDT",53,0)
 ..S PSOI=+^PSRX(DA,"OR1"),PSODAYS=$P(RX0,"^",8),PSORXST=+$P($G(^PS(53,$P(RX0,"^",3),0)),"^",7)
"RTN","PSOOREDT",54,0)
 ..I 'PSOI S PSOI=+^PSDRUG($P(RX0,"^",6),2),$P(^PSRX(DA,"OR1"),"^")=PSOI
"RTN","PSOOREDT",55,0)
 ..S:'$G(PSODRUG("IEN")) PSODRUG("IEN")=$P(RX0,"^",6),PSODRUG("NAME")=$P(^PSDRUG($P(RX0,"^",6),0),"^")
"RTN","PSOOREDT",56,0)
 ..S PSODRUG("OI")=PSOI
"RTN","PSOOREDT",57,0)
 .S PSORX("PROVIDER")=$P(RX0,"^",4),PSORX("PROVIDER NAME")=$P(^VA(200,$P(RX0,"^",4),0),"^"),PSOTRN=$G(^PSRX(DA,"TN"))
"RTN","PSOOREDT",58,0)
 .D:'$G(CHK) POP^PSOSIGNO(DA),CHK Q:$G(PSORXED("DFLG"))
"RTN","PSOOREDT",59,0)
 .S FDR="39.2^"_$S($P(PSOPAR,"^",3):"6",1:"")_";6.5^113^114^3^1^22R^24^8^7^9^4^11;"_$S($P(RX0,"^",11)="W"&($P(PSOPAR,"^",12)):"35;",1:"")_"^10.6^5^20^23^12^PSOCOU^RF^81"
"RTN","PSOOREDT",60,0)
 .I $G(ST)=11!($G(ST)=12)!($G(ST)=14)!($G(ST)=15) D NDCDAWDE^PSOORED7(ST,FLN,$G(RXN)) Q
"RTN","PSOOREDT",61,0)
 .S REF=0 S:$$LSTRFL^PSOBPSU1($P(PSOLST(ORN),"^",2)) REF=1  ;*377
"RTN","PSOOREDT",62,0)
 .I FLN=20,'$G(REF) S VALMSG="There is no Refill Data to be edited." Q
"RTN","PSOOREDT",63,0)
 .S DR=$P(FDR,"^",FLN) I DR="RF" D REF^PSOORED2 Q
"RTN","PSOOREDT",64,0)
 .I DR="PSOCOU" D PSOCOU^PSOORED6 Q
"RTN","PSOOREDT",65,0)
 .I FLN=2,'$P(PSOPAR,"^",3),$$RXRLDT^PSOBPSUT(RXN,0),$$STATUS^PSOBPSUT(RXN,0)'="" D  Q
"RTN","PSOOREDT",66,0)
 ..N NDC D NDC^PSODRG(RXN,0,,.NDC) I $G(NDC)="^"!($G(NDC)="") Q
"RTN","PSOOREDT",67,0)
 ..S (PSODRUG("NDC"),PSORXED("FLD",27))=NDC
"RTN","PSOOREDT",68,0)
 .I FLN'>2,'$P(PSOPAR,"^",3) S VALMSG="Check site parameters, Drug data is not editable." Q
"RTN","PSOOREDT",69,0)
 .I FLN=3 D EDTDOSE^PSOORED2,FULL^VALM1,POST^PSODRG S:$G(PSORX("DFLG")) PSOISLKD=1,PSORX("FN")=1 Q
"RTN","PSOOREDT",70,0)
 .I FLN=4 D INS^PSOORED1 Q
"RTN","PSOOREDT",71,0)
 .I FLN=1 D PSOI^PSOORED6 N PSOX S PSORXED=1,PSOX("IRXN")=$S($D(DA):DA,$D(PSORXED("IRXN")):PSORXED("IRXN"),$D(PSORENW("OIRXN")):PSORENW("OIRXN")) D:'$G(PSORXED("DFLG")) EN^PSODIAG Q
"RTN","PSOOREDT",72,0)
 .I FLN=2 D DRG^PSOORED6 N PSOX S PSORXED=1,PSOX("IRXN")=PSORXED("IRXN") D:'$G(PSORXED("DFLG")) EN^PSODIAG S:$O(^PSRX(PSORXED("IRXN"),1,0)) REF=1 Q
"RTN","PSOOREDT",73,0)
 .I FLN=12,PSOPKI W !!,"Digitally Signed Order - Provider can't be changed" D PAUSE Q
"RTN","PSOOREDT",74,0)
 .I FLN=12 D PROV Q
"RTN","PSOOREDT",75,0)
 .I FLN=6 D ISDT^PSOORED2 Q
"RTN","PSOOREDT",76,0)
 .I FLN=7 D FLDT^PSOORED2 Q
"RTN","PSOOREDT",77,0)
 .I FLN=21,$$STATUS^PSOBPSUT(RXN,0)="" S VALMSG="Invalid selection!" Q
"RTN","PSOOREDT",78,0)
 .I FLN=21 D  Q
"RTN","PSOOREDT",79,0)
 ..N DAW D EDTDAW^PSODAWUT(RXN,0,.DAW) I $G(DAW)="^" Q
"RTN","PSOOREDT",80,0)
 ..S (PSODRUG("DAW"),PSORXED("FLD",81))=DAW
"RTN","PSOOREDT",81,0)
 .I FLN=9!(FLN=10)!(FLN=11) D NOCHG^PSOORED7 Q
"RTN","PSOOREDT",82,0)
 .S DR=+DR
"RTN","PSOOREDT",83,0)
 .K DIR,DIRUT,DIROUT ;S DIE=52 D ^DIE I $D(Y) S PSORXED("DFLG")=1
"RTN","PSOOREDT",84,0)
 .K DIC,DIQ S DIC=52,DA=PSORXED("IRXN"),DIQ="PSORXED" D EN^DIQ1 K DIC,DIQ
"RTN","PSOOREDT",85,0)
 .S DIR("B")=$S($G(PSORXED("FLD",DR))]"":PSORXED("FLD",DR),1:PSORXED(52,DA,DR)),DIR(0)="52,"_DR D ^DIR
"RTN","PSOOREDT",86,0)
 .I DR=24!(DR=12) S PSORXED("FLD",DR)=X
"RTN","PSOOREDT",87,0)
 .I $D(DIRUT) K DIR,DIRUT,DUOUT,DTOUT,PSORXED(52,DA,DR),PSORXED("FLD",DR) Q
"RTN","PSOOREDT",88,0)
 .I DR'=5,X="@" W !,"Data Required!",! K DIC,DIQ,DR,DA,DIR,DIRUT,PSORXED(52,DA,DR),X,Y Q
"RTN","PSOOREDT",89,0)
 .I DR=5,X'="@" S Y=+Y
"RTN","PSOOREDT",90,0)
 .I DR=3!(DR=20)!(DR=23) S Y=+Y
"RTN","PSOOREDT",91,0)
 .S PSORXED("FLD",DR)=$S(X="@":X,1:Y) K DIR,DIRUT,DIROUT,X,Y,PSORXED(52,DA,DR)
"RTN","PSOOREDT",92,0)
 .I DR=11,PSORXED("FLD",DR)="W",$P(PSOPAR,"^",12) D
"RTN","PSOOREDT",93,0)
 ..D FIELD^DID(52,DR,"","LABEL","ZZ") S PSORXED(ZZ("LABEL"))=PSORXED("FLD",DR) K ZZ
"RTN","PSOOREDT",94,0)
 ..S DR=35,DIQ="PSORXED" D EN^DIQ1 K DIC,DIQ,DIRUT,DUOUT,DTOUT
"RTN","PSOOREDT",95,0)
 ..S:$G(PSORXED(52,DA,DR))]"" DIR("B")=PSORXED(52,DA,DR)
"RTN","PSOOREDT",96,0)
 ..S DIR(0)="52,"_(DR) D ^DIR I $D(DIRUT),X'="@" K DIR,DIRUT Q
"RTN","PSOOREDT",97,0)
 ..S PSORXED("FLD",DR)=X K DIR,DIRUT,DIROUT,X,Y,PSORXED(52,DA,DR)
"RTN","PSOOREDT",98,0)
 .I $G(PSORXED("FLD",DR))]"" D FIELD^DID(52,DR,"","LABEL","ZZ") S PSORXED(ZZ("LABEL"))=PSORXED("FLD",DR) K ZZ
"RTN","PSOOREDT",99,0)
 Q:$G(PSOSIGFL)
"RTN","PSOOREDT",100,0)
 S (RX1,I,RFD,RFDT)=0 F  S I=$O(^PSRX(PSORXED("IRXN"),1,I)) Q:'I  S RFD=I,RFDT=$P(^PSRX(PSORXED("IRXN"),1,I,0),"^"),RX1(I)=$G(RX1(I))+1
"RTN","PSOOREDT",101,0)
 Q
"RTN","PSOOREDT",102,0)
CHK S CHK=1 I $G(^PSDRUG($P(PSORXED("RX0"),"^",6),"I"))]"",^("I")<DT S VALMSG="This drug has been inactivated. ",PSORXED("DFLG")=1 Q
"RTN","PSOOREDT",103,0)
 K PSPOP I $G(PSODIV),$P(PSORXED("RX2"),"^",9)'=PSOSITE S PSPRXN=PSORXED("IRXN") D  Q:PSORXED("DFLG")
"RTN","PSOOREDT",104,0)
 .I '$P(PSOSYS,"^",2) S VALMSG="RX# "_$P(^PSRX(PSPRXN,0),"^")_" is not a valid choice. (Different Division)" S PSORXED("DFLG")=1 Q
"RTN","PSOOREDT",105,0)
 .I $P(PSOSYS,"^",3) K DIR,DUOUT,DTOUT D  K DIR,DUOUT,DTOUT Q
"RTN","PSOOREDT",106,0)
 ..W $C(7) S DIR("A",1)="",DIR("A",2)="RX# "_$P(^PSRX(PSPRXN,0),"^")_" is from another division.",DIR("A")="Continue: (Y/N)",DIR(0)="Y",DIR("?",1)="'Y' FOR YES",DIR("?")="'N' FOR NO"
"RTN","PSOOREDT",107,0)
 ..S DIR("B")="N" D ^DIR I 'Y!($D(DIRUT)) S PSORXED("DFLG")=1 W !
"RTN","PSOOREDT",108,0)
 ;
"RTN","PSOOREDT",109,0)
 I $P(^PSRX(PSORXED("IRXN"),"STA"),"^")=16 S PSORXED("DFLG")=1 S VALMSG="Prescriptions on Provider Hold cannot be edited." Q
"RTN","PSOOREDT",110,0)
CHKX K PSPOP,DIR,DTOUT,DUOUT,Y,X Q
"RTN","PSOOREDT",111,0)
 Q
"RTN","PSOOREDT",112,0)
PROV ;select provider
"RTN","PSOOREDT",113,0)
 S PSORXED("PROVIDER")=$P(RX0,"^",4),PSORXED("PROVIDER NAME")=$P(^VA(200,$P(RX0,"^",4),0),"^")
"RTN","PSOOREDT",114,0)
 D PROV^PSODIR(.PSORXED) I PSORXED("PROVIDER")'=$P(RX0,"^",4) D
"RTN","PSOOREDT",115,0)
 .K DIR,DIRUT W ! S DIR(0)="Y",DIR("A",1)="You have changed the name of the provider entered for this Rx."
"RTN","PSOOREDT",116,0)
 .S DIR("A",2)="This edit will cause the provider's name to be update for all fills.",DIR("A")="Do you want to continue" D ^DIR
"RTN","PSOOREDT",117,0)
 .I 'Y!$D(DIRUT) K PSORX("PROVIDER"),PSORX("PROVIDER NAME"),PSORX("COSIGNING PROVIDER") Q
"RTN","PSOOREDT",118,0)
 .S PSORXED("FLD",4)=PSORXED("PROVIDER") K DIR,DIRUT,DUOUT
"RTN","PSOOREDT",119,0)
 .S PSORXED("FLD",109)=$G(PSORXED("COSIGNING PROVIDER"))
"RTN","PSOOREDT",120,0)
 Q
"RTN","PSOOREDT",121,0)
UDPROV ;update provider
"RTN","PSOOREDT",122,0)
 S $P(^PSRX(PSORXED("IRXN"),0),"^",4)=PSORXED("PROVIDER"),$P(^(3),"^",3)=$G(PSORX("COSIGNING PROVIDER"))
"RTN","PSOOREDT",123,0)
 F XTY="1","P" F I=0:0 S I=$O(^PSRX(PSORXED("IRXN"),XTY,I)) Q:'I  S $P(^PSRX(PSORXED("IRXN"),XTY,I,0),"^",17)=PSORXED("PROVIDER") S:XTY RFED=I
"RTN","PSOOREDT",124,0)
 K XTY,I
"RTN","PSOOREDT",125,0)
 Q
"RTN","PSOOREDT",126,0)
SIG ;edit medication instructions (SIG)
"RTN","PSOOREDT",127,0)
 S PSOFDR=+$P(^PSRX(PSORXED("IRXN"),"SIG"),"^",2) I PSOFDR D
"RTN","PSOOREDT",128,0)
 .F I=0:0 S I=$O(^PSRX(PSORXED("IRXN"),"SIG1",I)) Q:'I  S SIG(I)=^PSRX(PSORXED("IRXN"),"SIG1",I,0)
"RTN","PSOOREDT",129,0)
 E  S PSORX("SIG")=$P(^PSRX(PSORXED("IRXN"),"SIG"),"^")
"RTN","PSOOREDT",130,0)
 D SIG^PSODIR1(.PSORX) D:$G(PSORX("SIG"))]"" EN1^PSOSIGNO(PSORXED("IRXN"),PSORX("SIG"))
"RTN","PSOOREDT",131,0)
 I '$G(PSOSIGFL),$G(PSORX("SIG"))]"" S ^PSRX(PSORXED("IRXN"),"SIG")=PSORX("SIG") K ^PSRX(PSORXED("IRXN"),"SIG1") Q
"RTN","PSOOREDT",132,0)
 S PSOMRFLG=1
"RTN","PSOOREDT",133,0)
 Q
"RTN","PSOOREDT",134,0)
UL ;
"RTN","PSOOREDT",135,0)
 I '$G(PSOLOKED) Q
"RTN","PSOOREDT",136,0)
 D UL^PSSLOCK(PSODFN)
"RTN","PSOOREDT",137,0)
 D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2))
"RTN","PSOOREDT",138,0)
 Q
"RTN","PSOOREDT",139,0)
SVAL ;Set message for patient lock
"RTN","PSOOREDT",140,0)
 S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.")
"RTN","PSOOREDT",141,0)
 Q
"RTN","PSOOREDT",142,0)
SVALO ;Set message for order lock
"RTN","PSOOREDT",143,0)
 S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order.")
"RTN","PSOOREDT",144,0)
 Q
"RTN","PSOOREDT",145,0)
 ;
"RTN","PSOOREDT",146,0)
PAUSE     ;
"RTN","PSOOREDT",147,0)
 N DIR,X,Y
"RTN","PSOOREDT",148,0)
 W ! S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR
"RTN","PSOOREDT",149,0)
 Q
"RTN","PSOOREDT",150,0)
 ; 
"RTN","PSOORFI1")
0^11^B83482862^B74027837
"RTN","PSOORFI1",1,0)
PSOORFI1 ;BIR/SAB - finish OP orders from OE/RR continued ;5/23/05 2:11pm
"RTN","PSOORFI1",2,0)
 ;;7.0;OUTPATIENT PHARMACY;**7,15,23,27,32,44,51,46,71,90,108,131,152,186,210,222,258,260,225,391**;DEC 1997;Build 13
"RTN","PSOORFI1",3,0)
 ;Ref. ^PS(50.7 supp. DBIA 2223
"RTN","PSOORFI1",4,0)
 ;Ref. ^PSDRUG( supp. DBIA 221
"RTN","PSOORFI1",5,0)
 ;Ref. L^PSSLOCK supp. DBIA 2789
"RTN","PSOORFI1",6,0)
 ;Ref. ^PS(50.606 supp. DBIA 2174
"RTN","PSOORFI1",7,0)
 ;Ref. ^PS(55 supp. DBIA 2228
"RTN","PSOORFI1",8,0)
 ;Ref. ULK^ORX2 supp. DBIA 867
"RTN","PSOORFI1",9,0)
 ;
"RTN","PSOORFI1",10,0)
 ;PSO*186 add call to function $$DEACHK
"RTN","PSOORFI1",11,0)
 ;PSO*210 add call to WORDWRAP api
"RTN","PSOORFI1",12,0)
 ;
"RTN","PSOORFI1",13,0)
 S SIGOK=1
"RTN","PSOORFI1",14,0)
DSPL K ^TMP("PSOPO",$J),CLOZPAT,PSOPRC,PSODSPL
"RTN","PSOORFI1",15,0)
 S (OI,PSODRUG("OI"))=$P(OR0,"^",8),PSODRUG("OIN")=$P(^PS(50.7,$P(OR0,"^",8),0),"^"),OID=$P(OR0,"^",9)
"RTN","PSOORFI1",16,0)
 I $P($G(OR0),"^",9) S POERR=1,DREN=$P(OR0,"^",9) D DRG^PSOORDRG K POERR G DRG
"RTN","PSOORFI1",17,0)
 I '$P(OR0,"^",9) D DREN^PSOORNW2
"RTN","PSOORFI1",18,0)
DRG I $P($G(^PSDRUG(+$G(PSODRUG("IEN")),"CLOZ1")),"^")="PSOCLO1" D CLOZ^PSOORFI2
"RTN","PSOORFI1",19,0)
 ;PSO*186 modify If/Else below to use DEACHK
"RTN","PSOORFI1",20,0)
 I $G(PSODRUG("DEA"))]"" D
"RTN","PSOORFI1",21,0)
 .S PSOCS=0 K DIR,DIC,PSOX
"RTN","PSOORFI1",22,0)
 .N PSDEA,PSDAYS S PSDEA=PSODRUG("DEA"),PSDAYS=+$P(OR0,"^",22)
"RTN","PSOORFI1",23,0)
 .I $$DEACHK^PSOUTLA1("*",PSDEA,PSDAYS,$G(CLOZPAT),.PSOCS,.PSOMAX)
"RTN","PSOORFI1",24,0)
 E  D
"RTN","PSOORFI1",25,0)
 .S PSOMAX=$S($G(CLOZPAT)=2:3,$G(CLOZPAT)=1:1,1:$P(OR0,"^",11))
"RTN","PSOORFI1",26,0)
ISSDT S (PSOID,Y,PSONEW("ISSUE DATE"))=$S($G(PSONEW("ISSUE DATE")):PSONEW("ISSUE DATE"),$P($G(OR0),"^",6):$E($P(OR0,"^",6),1,7),1:DT)
"RTN","PSOORFI1",27,0)
 X ^DD("DD") S PSONEW("ISSUE DATE")=Y
"RTN","PSOORFI1",28,0)
 D USER^PSOORFI2($P(OR0,"^",4)) S PSONEW("CLERK CODE")=$P(OR0,"^",4),PSORX("CLERK CODE")=USER1
"RTN","PSOORFI1",29,0)
 S (PSONEW("DFLG"),PSONEW("QFLG"))=0,PSODFN=$P(OR0,"^",2),PSONEW("QTY")=$P(OR0,"^",10),PSONEW("MAIL/WINDOW")=$S($P(OR0,"^",17)="M":"M",1:"W")
"RTN","PSOORFI1",30,0)
 S:$G(PSONEW("CLINIC"))']"" PSONEW("CLINIC")=+$P(OR0,"^",13),PSORX("CLINIC")=$S($D(^SC(PSONEW("CLINIC"),0)):$P(^SC(PSONEW("CLINIC"),0),"^"),1:"")
"RTN","PSOORFI1",31,0)
 S:$G(PSORX("CLINIC"))']"" PSORX("CLINIC")=$S($D(^SC(+$P(OR0,"^",13),0)):$P(^SC($P(OR0,"^",13),0),"^"),1:"")
"RTN","PSOORFI1",32,0)
 D USER^PSOORFI2($P(OR0,"^",5))
"RTN","PSOORFI1",33,0)
 S PSONEW("CLERK CODE")=$P(OR0,"^",4),PSONEW("PROVIDER")=$P(OR0,"^",5),PSONEW("PROVIDER NAME")=USER1
"RTN","PSOORFI1",34,0)
 S PSONEW("PATIENT STATUS")=$S(+$G(^PS(55,PSODFN,"PS")):+$G(^PS(55,PSODFN,"PS")),1:"")
"RTN","PSOORFI1",35,0)
 S PSONEW("CHCS NUMBER")=$S($P($G(^PS(52.41,+$G(ORD),"EXT")),"^")'="":$P($G(^("EXT")),"^"),1:"")
"RTN","PSOORFI1",36,0)
 S PSONEW("EXTERNAL SYSTEM")=$S($P($G(^PS(52.41,+$G(ORD),"EXT")),"^",3)'="":$P($G(^("EXT")),"^",3),1:"")
"RTN","PSOORFI1",37,0)
 I $P(OR0,"^",22)>0 S PSONEW("DAYS SUPPLY")=$P(OR0,"^",22) G DS
"RTN","PSOORFI1",38,0)
 S PSONEW("DAYS SUPPLY")=$S(+$G(^PS(55,PSODFN,"PS"))&($P($G(^PS(53,+$G(^PS(55,PSODFN,"PS")),0)),"^",3)):$P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",3),1:30)
"RTN","PSOORFI1",39,0)
DS S:$D(CLOZPAT) PSONEW("DAYS SUPPLY")=$S(CLOZPAT=2&(PSONEW("DAYS SUPPLY")>28):28,CLOZPAT=1&(PSONEW("DAYS SUPPLY")>14):14,'CLOZPAT&(PSONEW("DAYS SUPPLY")>7):7,1:PSONEW("DAYS SUPPLY"))
"RTN","PSOORFI1",40,0)
 S IEN=0 D OBX                ; Display Order Checks Information
"RTN","PSOORFI1",41,0)
 D LMDISP^PSOORFI5(+$G(ORD))  ; Display Flag/Unflag Information
"RTN","PSOORFI1",42,0)
 D DIN^PSONFI(PSODRUG("OI"),$S($D(PSODRUG("IEN")):PSODRUG("IEN"),1:"")) ;Setup for N/F & DIN indicator
"RTN","PSOORFI1",43,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="*(1) Orderable Item: "_$P(^PS(50.7,PSODRUG("OI"),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")_NFIO
"RTN","PSOORFI1",44,0)
 S:NFIO["<DIN>" NFIO=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4)
"RTN","PSOORFI1",45,0)
 D FULL^VALM1 K LST I $G(PSODRUG("NAME"))]"" D  G PST
"RTN","PSOORFI1",46,0)
 .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (2)"_$S($D(^PSDRUG("AQ",PSODRUG("IEN"))):"      CMOP ",1:"           ")_"Drug: "_PSODRUG("NAME")_NFID
"RTN","PSOORFI1",47,0)
 .S:NFID["<DIN>" NFID=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4)
"RTN","PSOORFI1",48,0)
 .I $P(^PSDRUG(PSODRUG("IEN"),0),"^",10)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="       Drug Message:" D DRGMSG^PSOORNEW
"RTN","PSOORFI1",49,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (2)           Drug: No Dispense Drug Selected"
"RTN","PSOORFI1",50,0)
PST D DOSE^PSOORFI4 K PSOINSFL
"RTN","PSOORFI1",51,0)
 S PSOINSFL=$P($G(^PS(52.41,ORD,"INS")),"^",2)
"RTN","PSOORFI1",52,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (4)   Pat Instruct:" D INST^PSOORFI4
"RTN","PSOORFI1",53,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  Provider Comments:" S TY=3 D INST
"RTN","PSOORFI1",54,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="       Instructions:" S TY=2 D INST
"RTN","PSOORFI1",55,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="                SIG:" D SIG
"RTN","PSOORFI1",56,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (5) Patient Status: "_$P($G(^PS(53,+PSONEW("PATIENT STATUS"),0)),"^")
"RTN","PSOORFI1",57,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (6)     Issue Date: "_PSONEW("ISSUE DATE")
"RTN","PSOORFI1",58,0)
 S (Y,PSONEW("FILL DATE"))=$S($E($P(OR0,"^",6),1,7)<DT:DT,1:$E($P(OR0,"^",6),1,7)) X ^DD("DD") S PSORX("FILL DATE")=Y,^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"        (7) Fill Date: "_Y
"RTN","PSOORFI1",59,0)
 I $P(OR0,"^",18) D
"RTN","PSOORFI1",60,0)
 .S IEN=IEN+1,Y=$P(OR0,"^",18) X ^DD("DD") S $P(^TMP("PSOPO",$J,IEN,0)," ",39)="Effective Date: "_Y
"RTN","PSOORFI1",61,0)
 D:$D(CLOZPAT) ELIG^PSOORFI2,CLQTY^PSOORFI4
"RTN","PSOORFI1",62,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (8)    Days Supply: "_$S($G(PSONEW("DAYS SUPPLY")):PSONEW("DAYS SUPPLY"),+$G(^PS(55,PSODFN,"PS"))&($P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",3)):$P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",3),1:"")
"RTN","PSOORFI1",63,0)
 I +$G(^PS(55,PSODFN,"PS")) S RXPT=+^("PS") I $G(^PS(53,RXPT,0))]"" D
"RTN","PSOORFI1",64,0)
 .S PSONEW("# OF REFILLS")=$S(+$P(OR0,"^",11)>+$P(^PS(53,RXPT,0),"^",4):+$P(^PS(53,RXPT,0),"^",4),1:+$P(OR0,"^",11)),PSOX=+$P(^PS(53,RXPT,0),"^",4)
"RTN","PSOORFI1",65,0)
 .S PSONEW("# OF REFILLS")=$S(PSONEW("# OF REFILLS")>PSOMAX:PSOMAX,1:PSONEW("# OF REFILLS"))
"RTN","PSOORFI1",66,0)
 .S PSOMAX=$S(PSOMAX>+$P(^PS(53,RXPT,0),"^",4):+$P(^PS(53,RXPT,0),"^",4),1:PSOMAX) K RXPT
"RTN","PSOORFI1",67,0)
 .S MPSDY=PSONEW("DAYS SUPPLY")
"RTN","PSOORFI1",68,0)
 .S MAXRF=$S(MPSDY<60:11,MPSDY'<60&(MPSDY'>89):5,MPSDY=90:3,1:0)
"RTN","PSOORFI1",69,0)
 .I PSONEW("# OF REFILLS")>MAXRF S PSONEW("# OF REFILLS")=MAXRF K MAXRF,MPSDY
"RTN","PSOORFI1",70,0)
 E  D
"RTN","PSOORFI1",71,0)
 . I $G(PSOMAX) S PSONEW("# OF REFILLS")=$S(+$P(OR0,"^",11)>PSOMAX:PSOMAX,1:+$P(OR0,"^",11)) Q
"RTN","PSOORFI1",72,0)
 .S PSONEW("# OF REFILLS")=+$P(OR0,"^",11)
"RTN","PSOORFI1",73,0)
 S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"                (9)   QTY"_$S($P($G(^PSDRUG(+$G(PSODRUG("IEN")),660)),"^",8)]"":" ("_$P($G(^PSDRUG(+$G(PSODRUG("IEN")),660)),"^",8)_")",1:" (  )")_": "
"RTN","PSOORFI1",74,0)
 S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_$S($D(CLOZPAT):+$G(PSONEW("QTY")),1:$P(OR0,"^",10))
"RTN","PSOORFI1",75,0)
 I $P($G(^PSDRUG(+$G(PSODRUG("IEN")),5)),"^")]"" D
"RTN","PSOORFI1",76,0)
 .S $P(RN," ",79)=" ",IEN=IEN+1
"RTN","PSOORFI1",77,0)
 .S ^TMP("PSOPO",$J,IEN,0)=$E(RN,$L("QTY DSP MSG: "_$P(^PSDRUG(PSODRUG("IEN"),5),"^"))+1,79)_"QTY DSP MSG: "_$P(^PSDRUG(PSODRUG("IEN"),5),"^") K RN
"RTN","PSOORFI1",78,0)
 S IEN=IEN+1
"RTN","PSOORFI1",79,0)
 I $P(OR0,"^",24) S ^TMP("PSOPO",$J,IEN,0)="   Provider ordered: days supply "_+$P(OR0,"^",22)_", quantity "_+$P(OR0,"^",10)_" & refills "_+$P(OR0,"^",11)
"RTN","PSOORFI1",80,0)
 E  S ^TMP("PSOPO",$J,IEN,0)="       Provider ordered "_+$P(OR0,"^",11)_" refills"
"RTN","PSOORFI1",81,0)
 D:$D(CLOZPAT) PQTY^PSOORFI4
"RTN","PSOORFI1",82,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(10)   # of Refills: "_PSONEW("# OF REFILLS")_$E("  ",$L(PSONEW("# OF REFILLS"))+1,2)_"               (11)   Routing: "_$S($G(PSONEW("MAIL/WINDOW"))="M":"MAIL",1:"WINDOW")
"RTN","PSOORFI1",83,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(12)         Clinic: "_PSORX("CLINIC")
"RTN","PSOORFI1",84,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(13)       Provider: "_PSONEW("PROVIDER NAME")
"RTN","PSOORFI1",85,0)
 I $G(PKI),+$G(PSODRUG("DEA"))>1,+$G(PSODRUG("DEA"))<6 D PRV^PSOORFI5($P(OR0,"^",5),$P(OR0,"^",9),$P(OR0,"^"))
"RTN","PSOORFI1",86,0)
 I $P($G(^VA(200,$S($G(PSONEW("PROVIDER")):PSONEW("PROVIDER"),1:$P(OR0,"^",5)),"PS")),"^",7)&($P($G(^("PS")),"^",8)) S PSONEW("COSIGNING PROVIDER")=$P(^("PS"),"^",8) D
"RTN","PSOORFI1",87,0)
 .D USER^PSOORFI2(PSONEW("COSIGNING PROVIDER"))
"RTN","PSOORFI1",88,0)
 .S IEN=IEN+1 S ^TMP("PSOPO",$J,IEN,0)="        Cos-Provider: "_USER1
"RTN","PSOORFI1",89,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(14)         Copies: 1"
"RTN","PSOORFI1",90,0)
 S PSONEW("REMARKS")=$S($P(OR0,"^",17)="C":"Administered in Clinic.",1:"")
"RTN","PSOORFI1",91,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(15)        Remarks: "_$S($G(PSONEW("REMARKS"))]"":PSONEW("REMARKS"),1:"")
"RTN","PSOORFI1",92,0)
 D USER^PSOORFI2($P(OR0,"^",4))
"RTN","PSOORFI1",93,0)
 S $P(RN," ",35)=" ",IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="   Entry By: "_USER1_$E(RN,$L(USER1)+1,35)
"RTN","PSOORFI1",94,0)
 S Y=$P(OR0,"^",12) X ^DD("DD") S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"Entry Date: "_$E($P(OR0,"^",12),4,5)_"/"_$E($P(OR0,"^",12),6,7)_"/"_$E($P(OR0,"^",12),2,3)_" "_$P(Y,"@",2) K RN
"RTN","PSOORFI1",95,0)
 I $P(OR0,"^",24) S PSOACT=$S($D(^XUSEC("PSDRPH",DUZ)):"DEFX",$D(^XUSEC("PSORPH",DUZ)):"F",$P($G(PSOPAR),"^",2):"F",1:"") D
"RTN","PSOORFI1",96,0)
 .K PSOCSP S PSOCSP("NAME")=$G(PSODRUG("NAME")) M PSOCSP("DOSE")=PSONEW("DOSE"),PSOCSP("DOSE ORDERED")=PSONEW("DOSE ORDERED")
"RTN","PSOORFI1",97,0)
 .S PSOCSP("# OF REFILLS")=PSONEW("# OF REFILLS") ;track original data for dig. orders
"RTN","PSOORFI1",98,0)
 .S PSOCSP("ISSUE DATE")=$E($P(OR0,"^",6),1,7),PSOCSP("QTY")=PSONEW("QTY"),PSOCSP("DAYS SUPPLY")=PSONEW("DAYS SUPPLY")
"RTN","PSOORFI1",99,0)
 E  S PSOACT=$S($D(^XUSEC("PSORPH",DUZ)):"DEFX",'$D(^XUSEC("PSORPH",DUZ))&($P($G(PSOPAR),"^",2)):"F",1:"")
"RTN","PSOORFI1",100,0)
 ; - PSOACTOV is used to force the Pending Order to be Read-Only (no updates) even if invoked by a Pharmacist
"RTN","PSOORFI1",101,0)
 I $G(PSOACTOV) S PSOACT=""
"RTN","PSOORFI1",102,0)
 D:'$G(ACP) EN^PSOLMPO S:$G(ACP) VALMBCK="Q" D:$G(PKI1)=2 DCP^PSOPKIV1
"RTN","PSOORFI1",103,0)
 Q
"RTN","PSOORFI1",104,0)
POST ;post patient selection
"RTN","PSOORFI1",105,0)
 D POST^PSOORFI2 Q
"RTN","PSOORFI1",106,0)
SIG ;displays possible sig
"RTN","PSOORFI1",107,0)
 D SIG^PSOORFI2 Q
"RTN","PSOORFI1",108,0)
INST ;displays provider comments and pharmacy instructions
"RTN","PSOORFI1",109,0)
 S INST=0 F  S INST=$O(^PS(52.41,ORD,TY,INST)) Q:'INST  D     ;PSO*210
"RTN","PSOORFI1",110,0)
 . S (MIG,INST(INST))=^PS(52.41,ORD,TY,INST,0)
"RTN","PSOORFI1",111,0)
 . D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOPO",$J)),20)
"RTN","PSOORFI1",112,0)
 K INST,TY,MIG,SG
"RTN","PSOORFI1",113,0)
 Q
"RTN","PSOORFI1",114,0)
OBX ;formats obx section
"RTN","PSOORFI1",115,0)
 D OBX^PSOORFI4
"RTN","PSOORFI1",116,0)
 Q
"RTN","PSOORFI1",117,0)
ST ;sort by route or patient
"RTN","PSOORFI1",118,0)
 W !!,"Enter 'PA' to process orders by patients",!,"      'RT' to process orders by route (mail/window)",!,"      'PR' to process orders by priority",!,"      'CL' to process orders by clinic"
"RTN","PSOORFI1",119,0)
 W !,"      'FL' to process flagged orders",!,"      'CS' to process digitally signed CS orders",!,"   or 'E' or '^' to exit" W ! Q
"RTN","PSOORFI1",120,0)
RT ;which route to sort by
"RTN","PSOORFI1",121,0)
 W !!,"Enter 'W' to process window orders first",!,"      'M' to process mail orders first",!,"      'C' to process orders administered in clinic first",!,"   or 'E' or '^' to exit" Q
"RTN","PSOORFI1",122,0)
PT ;process for all or one patient
"RTN","PSOORFI1",123,0)
 W !!,"Enter 'A' to process all patient orders",!,"      'S' to process orders for a patient",!,"      or 'E' or '^' to exit" Q
"RTN","PSOORFI1",124,0)
EP ;continue processing or not
"RTN","PSOORFI1",125,0)
 W !,"If you want to continue processing orders Press RETURN or enter '^' to exit" Q
"RTN","PSOORFI1",126,0)
LOCK S PSOPLCK=$$L^PSSLOCK(PAT,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S POERR("QFLG")=1
"RTN","PSOORFI1",127,0)
 K PSOPLCK
"RTN","PSOORFI1",128,0)
 Q
"RTN","PSOORFI1",129,0)
ULK S X=PAT_";DPT(" D ULK^ORX2 S:$G(PSOQUIT) POERR("QFLG")=1 ; not called anymore
"RTN","PSOORFI1",130,0)
 Q
"RTN","PSOORFI1",131,0)
LOCK1 ;
"RTN","PSOORFI1",132,0)
 I $P($G(^PS(52.41,ORD,0)),"^",24) S PSOACT=$S($D(^XUSEC("PSDRPH",DUZ)):"DEFX",$D(^XUSEC("PSORPH",DUZ)):"F",'$D(^XUSEC("PSORPH",DUZ))&($P($G(PSOPAR),"^",2)):"F",1:"")
"RTN","PSOORFI1",133,0)
 E  S PSOACT=$S($D(^XUSEC("PSORPH",DUZ)):"DEFX",'$D(^XUSEC("PSORPH",DUZ))&($P($G(PSOPAR),"^",2)):"F",1:"")
"RTN","PSOORFI1",134,0)
 Q
"RTN","PSOORFI1",135,0)
EX K DRET,SIG,PSODRUG,PRC,PHI
"RTN","PSOORFI1",136,0)
 K DIR,DIRUT,DUOUT,DIRUT,X,Y,DIC,POERR,PSONEW,PSOSD,MAIL,CLI,WIN,OR0,OR1,OR2,ORD,SRT,PSRT,PSODFN,PSOFROM,T,OR3,PAT,%,%T,%Y,DI,DQ,DR,DRG,STA,I,T1,PSOSORT,PSOCSP
"RTN","PSOORFI1",137,0)
 K TO,TC,TZ,PSOCPAY,PSOBILL,PSOIBQS,GROUPCNT,AGROUP,AGROUP1,OBX,%,%I,%H,D0,DFN,PSORX,PSOPTPST,PSOQFLG,PT,RTN,TM,TM1,DIPGM,PSOID,PSOCNT,PSOLK,PSZFIN,PSZFZZ D KVA^VADPT
"RTN","PSOORFI1",138,0)
 K PSOFDR,PSOQUIT,PSOFIN,^TMP("PSOAO",$J),^TMP("PSODA",$J),^TMP("PSOPO",$J),^TMP("PSOPF",$J),^TMP("PSOPI",$J),^TMP("PSOHDR",$J),MEDA,MEDP
"RTN","PSOORFI1",139,0)
 K C,CC,CNT,CRIT,D,DGI,DGS,DREN,IT,JJ,LG,MM,NIEN,PSOD,PATA,PSDAYS,PSOACT,PSOBM,PSOCOU,PSOCOUU,PSOFLAG,PSON,PSONOOR,PSOOPT,PSOPF,PSOPI,PSRF,RXFL,SDA,SEG1,SER,SERS,SLPPL,STAT,Z,Z4,ZDA
"RTN","PSOORFI1",140,0)
 D FULL^VALM1
"RTN","PSOORFI1",141,0)
 Q
"RTN","PSOORFI4")
0^31^B81023299^B81736847
"RTN","PSOORFI4",1,0)
PSOORFI4 ;BIR/SAB-CPRS order checks and display con't ;6/17/09 1:11pm
"RTN","PSOORFI4",2,0)
 ;;7.0;OUTPATIENT PHARMACY;**46,74,78,99,117,131,207,258,274,300,308,251,384,391**;DEC 1997;Build 13
"RTN","PSOORFI4",3,0)
 ;External reference to ^PS(51.2 supported by DBIA 2226
"RTN","PSOORFI4",4,0)
 ;External reference to ^PS(50.607 supported by DBIA 2221
"RTN","PSOORFI4",5,0)
 ;External reference ^PS(55 supported by DBIA 2228
"RTN","PSOORFI4",6,0)
 ;External reference to ^PS(50.7 is supported by DBIA 2223
"RTN","PSOORFI4",7,0)
 ;
"RTN","PSOORFI4",8,0)
ORCHK D ORCHK^PSOORNE6
"RTN","PSOORFI4",9,0)
 Q
"RTN","PSOORFI4",10,0)
INST ;displays patient instructions
"RTN","PSOORFI4",11,0)
 I $O(PSONEW("SIG",0)) G INST1
"RTN","PSOORFI4",12,0)
 S INST=0 F  S INST=$O(^PS(52.41,ORD,"INS1",INST)) Q:'INST  S (MIG,PSONEW("SIG",INST))=^PS(52.41,ORD,"INS1",INST,0) D
"RTN","PSOORFI4",13,0)
 .F SG=1:1:$L(MIG," ") S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " S ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(MIG," ",SG)
"RTN","PSOORFI4",14,0)
 I $P($G(^PS(55,PSODFN,"LAN")),"^"),$O(^PS(52.41,ORD,"INS1",0)) D
"RTN","PSOORFI4",15,0)
 .I $G(^PS(50.7,PSODRUG("OI"),"INS1"))]"" S (X,PSONEW("SINS"))=^PS(50.7,PSODRUG("OI"),"INS1") D SSIG^PSOHELP
"RTN","PSOORFI4",16,0)
 .I $G(SINS1)]"" S PSONEW("SINS")=$E(SINS1,2,250)
"RTN","PSOORFI4",17,0)
 .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Other Pat Instruct: "_$S($G(PSONEW("SINS"))]"":PSONEW("SINS"),1:"")
"RTN","PSOORFI4",18,0)
 K INST,TY,MIG,SG,SINS1
"RTN","PSOORFI4",19,0)
 Q
"RTN","PSOORFI4",20,0)
INST1 ;
"RTN","PSOORFI4",21,0)
 S INS=0 F  S INS=$O(PSONEW("SIG",INS)) Q:'INS  S MIG=PSONEW("SIG",INS) D
"RTN","PSOORFI4",22,0)
 .F SG=1:1:$L(MIG," ") S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " S ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(MIG," ",SG)
"RTN","PSOORFI4",23,0)
 K INST,TY,MIG,SG
"RTN","PSOORFI4",24,0)
 I $P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Other Pat Instruct: "_$S($G(PSONEW("SINS"))]"":PSONEW("SINS"),1:"")
"RTN","PSOORFI4",25,0)
 Q
"RTN","PSOORFI4",26,0)
PROVCOM ;
"RTN","PSOORFI4",27,0)
 I $O(PRC(0)),'$G(PSOPRC) D  D KV^PSOVER1
"RTN","PSOORFI4",28,0)
 .D EN^DDIOL("Provider Comments: ","","!")
"RTN","PSOORFI4",29,0)
 .F I=0:0 S I=$O(PRC(I)) Q:'I  D EN^DDIOL(PRC(I),"","!")
"RTN","PSOORFI4",30,0)
 .D KV^PSOVER1 S DIR(0)="Y",DIR("A")="Copy Provider Comments into the Patient Instructions",DIR("B")="No"
"RTN","PSOORFI4",31,0)
 .D ^DIR Q:'Y!($D(DIRUT))
"RTN","PSOORFI4",32,0)
 .;Check Provider Comments.  If any line contains more than 32
"RTN","PSOORFI4",33,0)
 .;characters with no spaces, display error message and quit.
"RTN","PSOORFI4",34,0)
 .;*308
"RTN","PSOORFI4",35,0)
 .I $$CHKCOM(.PRC) D  Q
"RTN","PSOORFI4",36,0)
 ..N X,Y,DIR,DIRUT,DUOUT,MSG
"RTN","PSOORFI4",37,0)
 ..S MSG(1)="*** Provider Comments CANNOT be copied ***"
"RTN","PSOORFI4",38,0)
 ..S MSG(1,"F")="!,$C(7)"
"RTN","PSOORFI4",39,0)
 ..S MSG(2)="They contain a word longer than 32 characters, which is not allowed in"
"RTN","PSOORFI4",40,0)
 ..S MSG(3)="the Patient Instructions.  You need to enter this manually."
"RTN","PSOORFI4",41,0)
 ..D EN^DDIOL(.MSG)
"RTN","PSOORFI4",42,0)
 ..S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR
"RTN","PSOORFI4",43,0)
 .S PSOPRC=1,NI=0 F I=0:0 S I=$O(PSONEW("SIG",I)) Q:'I  S NI=I
"RTN","PSOORFI4",44,0)
 .S NC=0 F I=0:0 S I=$O(PRC(I)) Q:'I  S NC=NC+1
"RTN","PSOORFI4",45,0)
 .I NI'>1,NC=1,($L($G(PSONEW("SIG",NI)))+$L(PRC(1)))'>250 D  Q 
"RTN","PSOORFI4",46,0)
 ..S X=PRC(1) D SIGONE^PSOHELP
"RTN","PSOORFI4",47,0)
 ..S PSONEW("SIG",1)=$G(PSONEW("SIG",NI))_INS1 K INS1,X
"RTN","PSOORFI4",48,0)
 ..S:$E(PSONEW("SIG",1))=" " PSONEW("SIG",1)=$E(PSONEW("SIG",1),2,250) S PSONEW("INS")=PSONEW("SIG",1) D EN^PSOFSIG(.PSONEW,1) K NI,NC
"RTN","PSOORFI4",49,0)
 .F I=0:0 S I=$O(PRC(I)) Q:'I  S NI=NI+1,(PSONEW("INS",NI),X)=PRC(I) D SIGONE^PSOHELP S PSONEW("SIG",NI)=INS1 K INS1
"RTN","PSOORFI4",50,0)
 .I $E(PSONEW("SIG",1))=" " S PSONEW("SIG",1)=$E(PSONEW("SIG",1),2,250)
"RTN","PSOORFI4",51,0)
 .D EN^PSOFSIG(.PSONEW,1) K NI,NC,X
"RTN","PSOORFI4",52,0)
 Q
"RTN","PSOORFI4",53,0)
CHKCOM(PRC) ;Check provider comments array PRC. If any comment line is longer than 32 characters with no spaces, return 1
"RTN","PSOORFI4",54,0)
 ;*308
"RTN","PSOORFI4",55,0)
 ;INPUT:  PRC( = Provider Comments array
"RTN","PSOORFI4",56,0)
 ;OUTPUT: PSOERR  = O - OK
"RTN","PSOORFI4",57,0)
 ;                = 1 - Error (Comments > 32 chars. w/ no spaces)
"RTN","PSOORFI4",58,0)
 N PSOX,PSOY,PSOZ,PSOERR
"RTN","PSOORFI4",59,0)
 S PSOERR=0
"RTN","PSOORFI4",60,0)
 I '$D(PRC) Q PSOERR
"RTN","PSOORFI4",61,0)
 S PSOX=0
"RTN","PSOORFI4",62,0)
 F  S PSOX=$O(PRC(PSOX)) Q:PSOX=""!PSOERR  I $L(PRC(PSOX))>32 D
"RTN","PSOORFI4",63,0)
 .S PSOZ=$L(PRC(PSOX)," ") F PSOY=1:1:PSOZ I $L($P(PRC(PSOX)," ",PSOY))>32 S PSOERR=1 Q
"RTN","PSOORFI4",64,0)
 Q PSOERR
"RTN","PSOORFI4",65,0)
DOSE ;displays dosing info for pending orders.  called from psoorfi1
"RTN","PSOORFI4",66,0)
 K II,UNITS S DS=1
"RTN","PSOORFI4",67,0)
 I '$O(^PS(52.41,ORD,1,0)) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (3)        *Dosage:" G DOSEX
"RTN","PSOORFI4",68,0)
 F I=0:0 S I=$O(^PS(52.41,ORD,1,I)) Q:'I  S DOSE=$G(^PS(52.41,ORD,1,I,1)),DOSE1=$G(^(2)) D  D DOSE1
"RTN","PSOORFI4",69,0)
 .S II=$G(II)+1 K PSONEW("UNITS",II)
"RTN","PSOORFI4",70,0)
 .S PSONEW("DOSE",II)=$P(DOSE1,"^"),PSONEW("DOSE ORDERED",II)=$P(DOSE1,"^",2),PSONEW("UNITS",II)=$P(DOSE,"^",9),PSONEW("NOUN",II)=$P(DOSE,"^",5)
"RTN","PSOORFI4",71,0)
 .S:$P(DOSE,"^",9) UNITS=$P(^PS(50.607,$P(DOSE,"^",9),0),"^")
"RTN","PSOORFI4",72,0)
 .S PSONEW("VERB",II)=$P(DOSE,"^",10),PSONEW("ROUTE",II)=$P(DOSE,"^",8)
"RTN","PSOORFI4",73,0)
 .S ROUTE="" S:$P(DOSE,"^",8) ROUTE=$P(^PS(51.2,$P(DOSE,"^",8),0),"^")
"RTN","PSOORFI4",74,0)
 .S PSONEW("SCHEDULE",II)=$P(DOSE,"^"),PSONEW("DURATION",II)=$P(DOSE,"^",2)
"RTN","PSOORFI4",75,0)
 .S DOENT=$G(DOENT)+1 I $P(DOSE,"^",6)]"" S PSONEW("CONJUNCTION",II)=$S($P(DOSE,"^",6)="S":"T",$P(DOSE,"^",6)="X":"X",1:"A")
"RTN","PSOORFI4",76,0)
 .I 'PSONEW("DOSE ORDERED",II),$G(PSONEW("VERB",II))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="               Verb: "_$G(PSONEW("VERB",II))
"RTN","PSOORFI4",77,0)
 .S:$G(DS) IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (3)"
"RTN","PSOORFI4",78,0)
DOSEX S PSONEW("ENT")=+$G(II) K DOSE,DOSE1,II,I,UNITS,ROUTE,DG
"RTN","PSOORFI4",79,0)
 Q
"RTN","PSOORFI4",80,0)
DOSE1 I $G(DS)=1 S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"        *Dosage:" D FMD^PSOORFI3 G DU
"RTN","PSOORFI4",81,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="            *Dosage:" D FMD^PSOORFI3
"RTN","PSOORFI4",82,0)
DU I 'PSONEW("DOSE ORDERED",I),$P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Oth. Lang. Dosage: "_$G(PSONEW("ODOSE",I))
"RTN","PSOORFI4",83,0)
 I PSONEW("DOSE ORDERED",II),$G(PSONEW("VERB",II))]"" D
"RTN","PSOORFI4",84,0)
 .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="               Verb: "_$G(PSONEW("VERB",II))
"RTN","PSOORFI4",85,0)
 .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="     Dispense Units: "_$S($E(PSONEW("DOSE ORDERED",II),1)=".":"0",1:"")_PSONEW("DOSE ORDERED",II)
"RTN","PSOORFI4",86,0)
 I PSONEW("NOUN",II)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="               Noun: "_PSONEW("NOUN",II)
"RTN","PSOORFI4",87,0)
 I $G(ROUTE)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="             *Route: "_$G(ROUTE)
"RTN","PSOORFI4",88,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="          *Schedule: "_PSONEW("SCHEDULE",II)
"RTN","PSOORFI4",89,0)
 I $G(PSONEW("DURATION",II))]"" D
"RTN","PSOORFI4",90,0)
 .S PSONEW("DURATION",II)=$S($E(PSONEW("DURATION",II),1)'?.N:$E(PSONEW("DURATION",II),2,99)_$E(PSONEW("DURATION",II),1),1:PSONEW("DURATION",II))
"RTN","PSOORFI4",91,0)
 .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="          *Duration: "_PSONEW("DURATION",II)_" ("_$S(PSONEW("DURATION",II)["M":"MINUTES",PSONEW("DURATION",II)["H":"HOURS",PSONEW("DURATION",II)["L":"MONTHS",PSONEW("DURATION",II)["W":"WEEKS",1:"DAYS")_")"
"RTN","PSOORFI4",92,0)
 I $G(PSONEW("CONJUNCTION",II))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="       *Conjunction: "_$S(PSONEW("CONJUNCTION",II)="T":"THEN",PSONEW("CONJUNCTION",II)="X":"EXCEPT",1:"AND")
"RTN","PSOORFI4",93,0)
 Q
"RTN","PSOORFI4",94,0)
DOSE2 ;displays pending order after edits.  called from psoornew
"RTN","PSOORFI4",95,0)
 I '$O(PSONEW("DOSE",0))!($O(PSONEW("DOSE",0))="") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (3)        *Dosage:" Q
"RTN","PSOORFI4",96,0)
 S DS=1
"RTN","PSOORFI4",97,0)
 F I=1:1:PSONEW("ENT") Q:'I  D  D DOSE3 K COJ
"RTN","PSOORFI4",98,0)
 .S:$G(PSONEW("UNITS",I))]"" UNITS=$P(^PS(50.607,PSONEW("UNITS",I),0),"^")
"RTN","PSOORFI4",99,0)
 .I $G(PSONEW("ROUTE",I))]"",$G(^PS(51.2,PSONEW("ROUTE",I),0))]"" S ROUTE=$P(^PS(51.2,PSONEW("ROUTE",I),0),"^")
"RTN","PSOORFI4",100,0)
 .S DUR=$G(PSONEW("DURATION",I)) S:$G(PSONEW("CONJUNCTION",I))]"" COJ=PSONEW("CONJUNCTION",I)
"RTN","PSOORFI4",101,0)
 .S NOUN=$G(PSONEW("NOUN",I)),VERB=$G(PSONEW("VERB",I))
"RTN","PSOORFI4",102,0)
 .I '$G(PSONEW("DOSE ORDERED",I)),$G(PSONEW("VERB",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="               Verb: "_$G(PSONEW("VERB",I))
"RTN","PSOORFI4",103,0)
 .S:$G(DS) IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (3)"
"RTN","PSOORFI4",104,0)
 K I,UNITS,ROUTE,DUR,COJ,VERB,NOUN,DG
"RTN","PSOORFI4",105,0)
 Q
"RTN","PSOORFI4",106,0)
DOSE3 I $G(DS)=1 S II=I,^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"        *Dosage:" D FMD^PSOORFI3 G DO
"RTN","PSOORFI4",107,0)
 S II=I,IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="            *Dosage:" D FMD^PSOORFI3
"RTN","PSOORFI4",108,0)
DO I '$G(PSONEW("DOSE ORDERED",I)),$P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Oth. Lang. Dosage: "_$G(PSONEW("ODOSE",I))
"RTN","PSOORFI4",109,0)
 I $G(PSONEW("DOSE ORDERED",I)),$G(PSONEW("VERB",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="               Verb: "_$G(PSONEW("VERB",I))
"RTN","PSOORFI4",110,0)
 I $G(PSONEW("DOSE ORDERED",I)) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="     Dispense Units: "_$S($E(PSONEW("DOSE ORDERED",I),1)=".":"0",1:"")_PSONEW("DOSE ORDERED",I)
"RTN","PSOORFI4",111,0)
 I $G(PSONEW("NOUN",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="               NOUN: "_PSONEW("NOUN",I)
"RTN","PSOORFI4",112,0)
 I $G(ROUTE)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="             *Route: "_$G(ROUTE)
"RTN","PSOORFI4",113,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="          *Schedule: "_PSONEW("SCHEDULE",I)
"RTN","PSOORFI4",114,0)
 I $G(PSONEW("DURATION",I))]"" D
"RTN","PSOORFI4",115,0)
 .S PSONEW("DURATION",I)=$S($E(PSONEW("DURATION",I),1)'?.N:$E(PSONEW("DURATION",I),2,99)_$E(PSONEW("DURATION",I),1),1:PSONEW("DURATION",I))
"RTN","PSOORFI4",116,0)
 .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="          *Duration: "_PSONEW("DURATION",I)_" ("_$S(PSONEW("DURATION",I)["M":"MINUTES",PSONEW("DURATION",I)["H":"HOURS",PSONEW("DURATION",I)["L":"MONTHS",PSONEW("DURATION",I)["W":"WEEKS",1:"DAYS")_")"
"RTN","PSOORFI4",117,0)
 I $G(PSONEW("CONJUNCTION",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="       *Conjunction: "_$S(PSONEW("CONJUNCTION",I)="T":"THEN",PSONEW("CONJUNCTION",I)="X":"EXCEPT",1:"AND")
"RTN","PSOORFI4",118,0)
 Q
"RTN","PSOORFI4",119,0)
OBX ;formats obx section
"RTN","PSOORFI4",120,0)
 N COM,II
"RTN","PSOORFI4",121,0)
 S IEN=0
"RTN","PSOORFI4",122,0)
 D:$G(PKI1) L1^PSOPKIV1
"RTN","PSOORFI4",123,0)
 I $O(^PS(52.41,ORD,"OBX",0)) S T=0,IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="CPRS Order Checks:" F  S T=$O(^PS(52.41,ORD,"OBX",T)) Q:'T  D  S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" "
"RTN","PSOORFI4",124,0)
 .S COM=$G(^PS(52.41,ORD,"OBX",T,0))
"RTN","PSOORFI4",125,0)
 .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="     " F II=1:1:$L(COM," ") D
"RTN","PSOORFI4",126,0)
 ..I $L(^TMP("PSOPO",$J,IEN,0)_" "_$P(COM," ",II))>80 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="     "
"RTN","PSOORFI4",127,0)
 ..S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_" "_$P(COM," ",II)
"RTN","PSOORFI4",128,0)
 .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="     Overriding Provider: "_$G(^PS(52.41,ORD,"OBX",T,1))
"RTN","PSOORFI4",129,0)
 .I $O(^PS(52.41,ORD,"OBX",T,2,0)) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="     Overriding Reason:"
"RTN","PSOORFI4",130,0)
 .F T1=0:0 S T1=$O(^PS(52.41,ORD,"OBX",T,2,T1)) Q:'T1  D
"RTN","PSOORFI4",131,0)
 ..S MIG=^PS(52.41,ORD,"OBX",T,2,T1,0)
"RTN","PSOORFI4",132,0)
 ..F SG=1:1:$L(MIG," ") S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",23)=" " S ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(MIG," ",SG)
"RTN","PSOORFI4",133,0)
 Q
"RTN","PSOORFI4",134,0)
PP S PSODFN=PAT D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2)
"RTN","PSOORFI4",135,0)
 Q
"RTN","PSOORFI4",136,0)
SPL K PSOFIN S POERR("QFLG")=0 S PSONOLCK=1,PSOPTLOK=PAT
"RTN","PSOORFI4",137,0)
 Q
"RTN","PSOORFI4",138,0)
CLQTY ;
"RTN","PSOORFI4",139,0)
 K PSONEW("QTY")
"RTN","PSOORFI4",140,0)
 D QTY^PSOSIG(.PSONEW)
"RTN","PSOORFI4",141,0)
 S:'$G(PSONEW("QTY")) PSONEW("QTY")=0
"RTN","PSOORFI4",142,0)
 Q
"RTN","PSOORFI4",143,0)
PQTY ;
"RTN","PSOORFI4",144,0)
 S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_", days supply of "_+$P(OR0,"^",22)_" and a qty of "_+$P(OR0,"^",10)
"RTN","PSOORFI4",145,0)
 Q
"RTN","PSOORFI4",146,0)
REF Q:$G(PSODRUG("DEA"))']""
"RTN","PSOORFI4",147,0)
 S CS=0 F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S CS=1
"RTN","PSOORFI4",148,0)
 S PTRF=PSONEW("# OF REFILLS"),PSDAYS=PSONEW("DAYS SUPPLY")
"RTN","PSOORFI4",149,0)
 I CS D
"RTN","PSOORFI4",150,0)
 .S PSOX1=$S(PTRF>5:5,1:PTRF),PSOX=$S(PSOX1=5:5,1:PSOX1)
"RTN","PSOORFI4",151,0)
 .S PSOX=$S('PSOX:0,PSDAYS=90:1,1:PSOX),PSDY1=$S(PSDAYS<60:5,PSDAYS'<60&(PSDAYS'>89):2,PSDAYS=90:1,1:0)
"RTN","PSOORFI4",152,0)
 E  D
"RTN","PSOORFI4",153,0)
 .S PSOX1=PTRF,PSOX=$S(PSOX1=11:11,1:PSOX1),PSOX=$S('PSOX:0,PSDAYS=90:3,1:PSOX)
"RTN","PSOORFI4",154,0)
 .S PSDY1=$S(PSDAYS<60:11,PSDAYS'<60&(PSDAYS'>89):5,PSDAYS=90:3,1:0)
"RTN","PSOORFI4",155,0)
 S PSONEW("# OF REFILLS")=$S(PSONEW("# OF REFILLS")>PSDY1:PSDY1,1:PSONEW("# OF REFILLS"))
"RTN","PSOORFI4",156,0)
 Q
"RTN","PSOORFI5")
0^10^B46664581^B19521565
"RTN","PSOORFI5",1,0)
PSOORFI5 ;BIR/SJA-finish cprs orders ; 8/27/08 4:47pm
"RTN","PSOORFI5",2,0)
 ;;7.0;OUTPATIENT PHARMACY;**225,315,266,391**;DEC 1997;Build 13
"RTN","PSOORFI5",3,0)
 ;External references UL^PSSLOCK supported by DBIA 2789
"RTN","PSOORFI5",4,0)
 ;External reference to ^DPT supported by DBIA 10035
"RTN","PSOORFI5",5,0)
 ;
"RTN","PSOORFI5",6,0)
FLG W ! K MEDP,MEDA,POERR("DFLG"),DIR D KQ S PSOSORT="FLAGGED^FLAGGED"
"RTN","PSOORFI5",7,0)
 S LG=0,PATA=0 F  S LG=$O(^PS(52.41,"AD",LG)) Q:'LG!($G(POERR("QFLG")))  F PSOD=0:0 S PSOD=$O(^PS(52.41,"AD",LG,PSOPINST,PSOD)) Q:'PSOD!($G(POERR("QFLG")))  D
"RTN","PSOORFI5",8,0)
 .Q:'$D(^PS(52.41,PSOD,0))!('$P($G(^PS(52.41,PSOD,0)),"^",23))
"RTN","PSOORFI5",9,0)
 .Q:$G(PAT($P(^PS(52.41,PSOD,0),"^",2)))=$P(^PS(52.41,PSOD,0),"^",2)  S PAT=$P(^PS(52.41,PSOD,0),"^",2)
"RTN","PSOORFI5",10,0)
 .I PAT'=PATA,$O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN
"RTN","PSOORFI5",11,0)
 .D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q
"RTN","PSOORFI5",12,0)
 .I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG,PSOQQ Q
"RTN","PSOORFI5",13,0)
 .S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT
"RTN","PSOORFI5",14,0)
 .D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) D SPL D OERR^PSORX1 S PSOFIN=1 D QU S X=PSOPTLOK D KLLP,ULP,KLL Q
"RTN","PSOORFI5",15,0)
 .D SDFN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG Q
"RTN","PSOORFI5",16,0)
 .S PAT(PAT)=PAT
"RTN","PSOORFI5",17,0)
 .F ORD=0:0 S ORD=$O(^PS(52.41,"AOR",PAT,PSOPINST,ORD)) Q:'ORD!($G(POERR("QFLG")))!($G(PSOQQ))  D
"RTN","PSOORFI5",18,0)
 ..I $P($G(^PS(52.41,ORD,0)),"^",23) D PP,LK1,ORD^PSOORFIN
"RTN","PSOORFI5",19,0)
 .S X=PAT D ULP K PSOQQ
"RTN","PSOORFI5",20,0)
 I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN
"RTN","PSOORFI5",21,0)
 I $G(PSOQUIT) K PSOQUIT D EX G ^PSOORFIN
"RTN","PSOORFI5",22,0)
 G EX
"RTN","PSOORFI5",23,0)
 ;
"RTN","PSOORFI5",24,0)
PRI ; Called from PSOORFIN due to it's routine size.
"RTN","PSOORFI5",25,0)
 K DIR S PSOSORT="PRIORITY"
"RTN","PSOORFI5",26,0)
 S DIR("A")="Select Priority",DIR(0)="SBM^S:STAT;E:EMERGENCY;R:ROUTINE",DIR("B")="ROUTINE"
"RTN","PSOORFI5",27,0)
 D ^DIR G:$D(DIRUT) EX S PSOSORT=PSOSORT_"^"_Y,PSRT=Y
"RTN","PSOORFI5",28,0)
 S LG=0,PATA=0 F  S LG=$O(^PS(52.41,"AD",LG)) Q:'LG!($G(POERR("QFLG")))  F PSOD=0:0 S PSOD=$O(^PS(52.41,"AD",LG,PSOPINST,PSOD)) Q:'PSOD!($G(POERR("QFLG")))  D
"RTN","PSOORFI5",29,0)
 .Q:$P($G(^PS(52.41,PSOD,0)),"^",23)
"RTN","PSOORFI5",30,0)
 .Q:$G(PAT($P(^PS(52.41,PSOD,0),"^",2)))=$P(^PS(52.41,PSOD,0),"^",2)  S PAT=$P(^PS(52.41,PSOD,0),"^",2)
"RTN","PSOORFI5",31,0)
 .;PSO*7*266
"RTN","PSOORFI5",32,0)
 .I PAT'=PATA D LBL^PSOORFIN
"RTN","PSOORFI5",33,0)
 .I '$O(^PS(52.41,"AP",PAT,PSRT,0)) S PSOLK=1,PAT(PAT)=PAT Q
"RTN","PSOORFI5",34,0)
 .D PRI^PSOORFI2 I $G(PSZFIN) S PSOLK=1,PAT(PAT)=PAT Q
"RTN","PSOORFI5",35,0)
 .D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q
"RTN","PSOORFI5",36,0)
 .I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP Q
"RTN","PSOORFI5",37,0)
 .S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT
"RTN","PSOORFI5",38,0)
 .D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) D SPL D OERR^PSORX1 S PSOFIN=1 D QU S X=PSOPTLOK D KLLP,ULP,KLL Q
"RTN","PSOORFI5",39,0)
 .D SDFN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG Q
"RTN","PSOORFI5",40,0)
 .D PP S ORD=0 D @PSRT S PAT(PAT)=PAT
"RTN","PSOORFI5",41,0)
 .S X=PAT D ULP
"RTN","PSOORFI5",42,0)
 ;PSO*7*266
"RTN","PSOORFI5",43,0)
 D LBL^PSOORFIN
"RTN","PSOORFI5",44,0)
 I $G(PSOQUIT) K PSOQUIT D EX G ^PSOORFIN
"RTN","PSOORFI5",45,0)
EX D EX^PSOORFI1
"RTN","PSOORFI5",46,0)
 Q
"RTN","PSOORFI5",47,0)
LK D LOCK^PSOORFI1
"RTN","PSOORFI5",48,0)
 Q
"RTN","PSOORFI5",49,0)
LK1 D LOCK1^PSOORFI1 Q
"RTN","PSOORFI5",50,0)
QU I $G(PSOQUIT) S POERR("QFLG")=1 K PSOQUIT
"RTN","PSOORFI5",51,0)
 S:$G(PSOQFLG) PAT(PAT)=PAT
"RTN","PSOORFI5",52,0)
 Q
"RTN","PSOORFI5",53,0)
ULP K PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP")
"RTN","PSOORFI5",54,0)
 D CLEAN^PSOVER1
"RTN","PSOORFI5",55,0)
 I '$G(X) Q
"RTN","PSOORFI5",56,0)
 D UL^PSSLOCK(X) Q
"RTN","PSOORFI5",57,0)
KLL K PSOPTLOK
"RTN","PSOORFI5",58,0)
 Q
"RTN","PSOORFI5",59,0)
KLLP K PSONOLCK
"RTN","PSOORFI5",60,0)
 Q
"RTN","PSOORFI5",61,0)
SPL D SPL^PSOORFI4
"RTN","PSOORFI5",62,0)
 Q
"RTN","PSOORFI5",63,0)
SDFN S PSODFN=+$G(PSODFN)
"RTN","PSOORFI5",64,0)
 Q
"RTN","PSOORFI5",65,0)
PP D PP^PSOORFI4
"RTN","PSOORFI5",66,0)
 Q
"RTN","PSOORFI5",67,0)
KQ K PSOQUIT,POERR("QFLG")
"RTN","PSOORFI5",68,0)
 Q
"RTN","PSOORFI5",69,0)
S D S^PSOORFI2 ; Process STAT priority
"RTN","PSOORFI5",70,0)
 Q
"RTN","PSOORFI5",71,0)
 ;
"RTN","PSOORFI5",72,0)
E D E^PSOORFI2 ; Process EMERGENCY priority
"RTN","PSOORFI5",73,0)
 Q
"RTN","PSOORFI5",74,0)
 ;
"RTN","PSOORFI5",75,0)
R D R^PSOORFI2 ; Process ROUTINE priority
"RTN","PSOORFI5",76,0)
 Q
"RTN","PSOORFI5",77,0)
 ;
"RTN","PSOORFI5",78,0)
LMDISP(ORD) ; Backdoor ListManager Display of Flag/Unflag Informaiton
"RTN","PSOORFI5",79,0)
 N FLAG
"RTN","PSOORFI5",80,0)
 K FLAGLINE S ORD=+$G(ORD) I 'ORD Q
"RTN","PSOORFI5",81,0)
 ;
"RTN","PSOORFI5",82,0)
 I '$G(^PS(52.41,ORD,"FLG")) Q
"RTN","PSOORFI5",83,0)
 ; S X=IORVON_"Flagged"_IORVOFF
"RTN","PSOORFI5",84,0)
 D GETS^DIQ(52.41,ORD,"33;34;35;36;37;38","IE","FLAG")
"RTN","PSOORFI5",85,0)
 S L1="Flagged by "_$E(FLAG(52.41,ORD_",",34,"E"),1,30)_" on "_$$FMTE^XLFDT(FLAG(52.41,ORD_",",33,"I"),2)_": "
"RTN","PSOORFI5",86,0)
 S LEN=80-$L(L1),L1=L1_$E(FLAG(52.41,ORD_",",35,"E"),1,LEN),L2=$E(FLAG(52.41,ORD_",",35,"E"),LEN+1,999)
"RTN","PSOORFI5",87,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=L1,FLAGLINE(IEN)=7
"RTN","PSOORFI5",88,0)
 I L2'="" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=L2
"RTN","PSOORFI5",89,0)
 I FLAG(52.41,ORD_",",36,"I")'="" D
"RTN","PSOORFI5",90,0)
 . S L1="Unflagged by "_$E(FLAG(52.41,ORD_",",37,"E"),1,30)_" on "_$$FMTE^XLFDT(FLAG(52.41,ORD_",",36,"I"),2)_": "
"RTN","PSOORFI5",91,0)
 . S LEN=80-$L(L1),L1=L1_$E(FLAG(52.41,ORD_",",38,"E"),1,LEN),L2=$E(FLAG(52.41,ORD_",",38,"E"),LEN+1,999)
"RTN","PSOORFI5",92,0)
 . S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=L1,FLAGLINE(IEN)=9
"RTN","PSOORFI5",93,0)
 . I L2'="" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=L2
"RTN","PSOORFI5",94,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" "
"RTN","PSOORFI5",95,0)
 Q
"RTN","PSOORFI5",96,0)
 ;
"RTN","PSOORFI5",97,0)
CS ; Digitally Signed CS - PSO*7*391
"RTN","PSOORFI5",98,0)
 K DIR N PSOCSRT S DIR("A")="Route",DIR(0)="SBM^W:WINDOW;M:MAIL;B:BOTH;E:EXIT",DIR("B")="BOTH" D ^DIR
"RTN","PSOORFI5",99,0)
 Q:$D(DIRUT)!(Y="E")
"RTN","PSOORFI5",100,0)
 S PSOCSRT=$S(Y="B":1,1:Y)
"RTN","PSOORFI5",101,0)
 W !!,"Select a schedule(s)"
"RTN","PSOORFI5",102,0)
 K DIR S PSOSORT="DIGITALLY SIGNED"
"RTN","PSOORFI5",103,0)
 S DIR("A")="Select Schedule(s)",DIR(0)="S^1:SCHEDULE II;2:SCHEDULES III - V;3:SCHEDULES II - V;E:EXIT",DIR("B")=3
"RTN","PSOORFI5",104,0)
 D ^DIR G:$D(DIRUT)!(Y="E") EX S PSOSORT=PSOSORT_"^"_Y,PSRT=Y
"RTN","PSOORFI5",105,0)
 N PDEA,OR0 S LG=0,PATA=0 F  S LG=$O(^PS(52.41,"AD",LG)) Q:'LG!($G(POERR("QFLG")))  F PSOD=0:0 S PSOD=$O(^PS(52.41,"AD",LG,PSOPINST,PSOD)) Q:'PSOD!($G(POERR("QFLG")))  D
"RTN","PSOORFI5",106,0)
 .Q:'$D(^PS(52.41,PSOD,0))
"RTN","PSOORFI5",107,0)
 .S OR0=^PS(52.41,PSOD,0)
"RTN","PSOORFI5",108,0)
 .Q:$P(OR0,"^",23)!('$P(OR0,"^",24))
"RTN","PSOORFI5",109,0)
 .S PDEA=0 D PDEA Q:'PDEA!(PDEA'=PSRT)
"RTN","PSOORFI5",110,0)
 .I 'PSOCSRT,PSOCSRT'=$P(OR0,"^",17) Q
"RTN","PSOORFI5",111,0)
 .Q:$G(PAT($P(OR0,"^",2)))=$P(OR0,"^",2)  S PAT=$P(OR0,"^",2)
"RTN","PSOORFI5",112,0)
 .I PAT'=PATA,$O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN
"RTN","PSOORFI5",113,0)
 .D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q
"RTN","PSOORFI5",114,0)
 .I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG,PSOQQ Q
"RTN","PSOORFI5",115,0)
 .S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT
"RTN","PSOORFI5",116,0)
 .D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) D SPL D OERR^PSORX1 S PSOFIN=1 D QU S X=PSOPTLOK D KLLP,ULP,KLL Q
"RTN","PSOORFI5",117,0)
 .D SDFN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG Q
"RTN","PSOORFI5",118,0)
 .S PAT(PAT)=PAT
"RTN","PSOORFI5",119,0)
 .F ORD=0:0 S ORD=$O(^PS(52.41,"AOR",PAT,PSOPINST,ORD)) Q:'ORD!($G(POERR("QFLG")))!($G(PSOQQ))  D
"RTN","PSOORFI5",120,0)
 ..Q:'$D(^PS(52.41,ORD,0))
"RTN","PSOORFI5",121,0)
 ..S OR0=^PS(52.41,ORD,0)
"RTN","PSOORFI5",122,0)
 ..Q:$P(OR0,"^",23)!('$P(OR0,"^",24))
"RTN","PSOORFI5",123,0)
 ..I 'PSOCSRT,PSOCSRT'=$P(OR0,"^",17) Q
"RTN","PSOORFI5",124,0)
 ..Q:$P(OR0,"^",3)="DC"!($P(OR0,"^",3)="DE")
"RTN","PSOORFI5",125,0)
 ..S PDEA=0 D PDEA Q:'PDEA!(PDEA'=PSRT)
"RTN","PSOORFI5",126,0)
 ..D PP,LK1,ORD^PSOORFIN
"RTN","PSOORFI5",127,0)
 .S X=PAT D ULP K PSOQQ
"RTN","PSOORFI5",128,0)
 I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN
"RTN","PSOORFI5",129,0)
 I $G(PSOQUIT) K PSOQUIT D EX G ^PSOORFIN
"RTN","PSOORFI5",130,0)
 G EX
"RTN","PSOORFI5",131,0)
 ;
"RTN","PSOORFI5",132,0)
PDEA ;
"RTN","PSOORFI5",133,0)
 I +$P(OR0,"^",9) S PDEA=$P($G(^PSDRUG($P(OR0,"^",9),0)),"^",3),PDEA=$S(PDEA[2:1,PDEA[3!(PDEA[4)!(PDEA[5):2,1:0)
"RTN","PSOORFI5",134,0)
 E  S PDEA=$$OIDEA^PSSUTLA1($P(OR0,"^",8),"O")
"RTN","PSOORFI5",135,0)
 I PDEA,PSRT=3 S PDEA=3
"RTN","PSOORFI5",136,0)
 Q
"RTN","PSOORFI5",137,0)
 ;
"RTN","PSOORFI5",138,0)
PRV(PROV,DRG,ORN) ;
"RTN","PSOORFI5",139,0)
 N DETN,DEA,I,LBL,VADD,SPC
"RTN","PSOORFI5",140,0)
 I PROV="" Q
"RTN","PSOORFI5",141,0)
 S DEA=$$DEA^XUSER(0,PROV)
"RTN","PSOORFI5",142,0)
 S LBL=$S(DEA["-":" VA#: ",1:"DEA#: ") I $G(ADDS) S LBL=" "_LBL
"RTN","PSOORFI5",143,0)
 I DRG,$$DETOX^PSSOPKI(DRG) S DETN=$$DETOX^XUSER(PROV)
"RTN","PSOORFI5",144,0)
 S $P(SPC," ",($S($G(ADDS):30,1:33)-$L(DEA)))=" "
"RTN","PSOORFI5",145,0)
 I (DEA'="")!($G(DETN)'="") S IEN=IEN+1,$E(^TMP("PSOPO",$J,IEN,0),16)=LBL_DEA_$S($G(DETN)]"":SPC_"DETOX#: "_$G(DETN),1:"")
"RTN","PSOORFI5",146,0)
 I $G(ORN) D PRVAD^PSOPKIV2 I $G(VADD(1))]"" D
"RTN","PSOORFI5",147,0)
 .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=$S($G(ADDS):" ",1:"")_"       Site Address: "_VADD(1)
"RTN","PSOORFI5",148,0)
 .S:VADD(2)'="" IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=$S($G(ADDS):" ",1:"")_"                     "_VADD(2) S:VADD(3)'="" IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=$S($G(ADDS):" ",1:"")_"                     "_VADD(3)
"RTN","PSOORFI5",149,0)
 Q
"RTN","PSOORFI5",150,0)
 ;
"RTN","PSOORFIN")
0^2^B63039564^B62133110
"RTN","PSOORFIN",1,0)
PSOORFIN ;BIR/SAB-finish cprs orders ; 8/27/08 4:57pm
"RTN","PSOORFIN",2,0)
 ;;7.0;OUTPATIENT PHARMACY;**7,15,27,32,44,46,84,106,111,117,131,146,139,195,225,315,266,338,391**;DEC 1997;Build 13
"RTN","PSOORFIN",3,0)
 ;PSSLOCK-2789,PSDRUG-221,50.7-2223,55-2228,50.606-2174
"RTN","PSOORFIN",4,0)
 ;PSO*7*266 Change order of calling ^PSOBING1 and ^PSORXL
"RTN","PSOORFIN",5,0)
 ;
"RTN","PSOORFIN",6,0)
 D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) D MSG^PSODPT G EX
"RTN","PSOORFIN",7,0)
 D INST^PSOORFI2 I $G(PSOIQUIT) K PSOIQUIT G EX
"RTN","PSOORFIN",8,0)
 I $P($G(PSOPAR),"^",2),'$D(^XUSEC("PSORPH",DUZ)) S PSORX("VERIFY")=1
"RTN","PSOORFIN",9,0)
 S (PSOFIN,POERR)=1
"RTN","PSOORFIN",10,0)
 K PSOBCK,MEDA,MEDP,SRT,DIR D KQ
"RTN","PSOORFIN",11,0)
 S DIR("?")="^D ST^PSOORFI1",DIR("A")="Select By",DIR("B")="PATIENT",DIR(0)="SMB^PA:PATIENT;RT:ROUTE;PR:PRIORITY;CL:CLINIC;FL:FLAGGED;CS:CONTROLLED SUBSTANCES;E:EXIT"
"RTN","PSOORFIN",12,0)
 D ^DIR I $D(DIRUT)!(Y="E") G EX
"RTN","PSOORFIN",13,0)
 K:Y="FL" ^TMP($J,"PSOFLPO") ;file not needed when selection="FL"
"RTN","PSOORFIN",14,0)
 G:Y="PA" PAT G:Y="PR" PRI^PSOORFI5 G:Y="CL" ^PSOORFI3 G:Y="FL" FLG^PSOORFI5 G:Y="CS" CS^PSOORFI5
"RTN","PSOORFIN",15,0)
 K DIR S PSOSORT="ROUTE"
"RTN","PSOORFIN",16,0)
 S DIR("?")="^D RT^PSOORFI1",DIR("A")="Route",DIR(0)="SBM^W:WINDOW;M:MAIL;C:CLINIC;E:EXIT",DIR("B")="WINDOW"
"RTN","PSOORFIN",17,0)
 D ^DIR G:$D(DIRUT)!(Y="E") EX S PSOSORT=PSOSORT_"^"_Y,PSRT=Y
"RTN","PSOORFIN",18,0)
 S LG=0,PATA=0 F  S LG=$O(^PS(52.41,"AD",LG)) Q:'LG!($G(POERR("QFLG")))  F PSOD=0:0 S PSOD=$O(^PS(52.41,"AD",LG,PSOPINST,PSOD)) Q:'PSOD!($G(POERR("QFLG")))  D
"RTN","PSOORFIN",19,0)
 .Q:$P($G(^PS(52.41,PSOD,0)),"^",23)
"RTN","PSOORFIN",20,0)
 .Q:$G(PAT($P(^PS(52.41,PSOD,0),"^",2)))=$P(^PS(52.41,PSOD,0),"^",2)  S PAT=$P(^PS(52.41,PSOD,0),"^",2)
"RTN","PSOORFIN",21,0)
 .;PSO*7*266
"RTN","PSOORFIN",22,0)
 .I PAT'=PATA D LBL
"RTN","PSOORFIN",23,0)
 .I '$O(^PS(52.41,"AC",PAT,PSRT,0)) S PSOLK=1,PAT(PAT)=PAT Q
"RTN","PSOORFIN",24,0)
 .D RTE^PSOORFI2 I $G(PSZFIN) S PSOLK=1,PAT(PAT)=PAT Q
"RTN","PSOORFIN",25,0)
 .D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q
"RTN","PSOORFIN",26,0)
 .I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP Q
"RTN","PSOORFIN",27,0)
 .S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT
"RTN","PSOORFIN",28,0)
 .D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) D SPL D OERR^PSORX1 S PSOFIN=1 D QU S X=PSOPTLOK D KLLP,ULP,KLL Q
"RTN","PSOORFIN",29,0)
 .D SDFN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG Q
"RTN","PSOORFIN",30,0)
 .D PP S ORD=0 D @PSRT S PAT(PAT)=PAT
"RTN","PSOORFIN",31,0)
 .S X=PAT D ULP
"RTN","PSOORFIN",32,0)
 ;PSO*7*266
"RTN","PSOORFIN",33,0)
 K POERR("QFLG"),PSOQFLG,PSOPTPST,MAIL,WIN,CLI D LBL
"RTN","PSOORFIN",34,0)
 I $G(PSOQUIT) K PSOQUIT D EX G PSOORFIN
"RTN","PSOORFIN",35,0)
EX D EX^PSOORFI1
"RTN","PSOORFIN",36,0)
 Q
"RTN","PSOORFIN",37,0)
W D KQ F  S ORD=$O(^PS(52.41,"AC",PAT,"W",ORD)) Q:'ORD!($G(POERR("QFLG")))  I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD S MAIL=1
"RTN","PSOORFIN",38,0)
 Q:$G(POERR("QFLG"))  I $G(MAIL) S ORD=0 D
"RTN","PSOORFIN",39,0)
 .D KQ F  S ORD=$O(^PS(52.41,"AC",PAT,"M",ORD)) Q:'ORD!($G(POERR("QFLG")))  D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD
"RTN","PSOORFIN",40,0)
 .Q:$G(POERR("QFLG"))
"RTN","PSOORFIN",41,0)
 .D KQ F  S ORD=$O(^PS(52.41,"AC",PAT,"C",ORD)) Q:'ORD!($G(POERR("QFLG")))  D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD
"RTN","PSOORFIN",42,0)
 Q
"RTN","PSOORFIN",43,0)
M D KQ F  S ORD=$O(^PS(52.41,"AC",PAT,"M",ORD)) Q:'ORD!($G(POERR("QFLG")))  I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD S WIN=1
"RTN","PSOORFIN",44,0)
 Q:$G(POERR("QFLG"))  I $G(WIN) S ORD=0 D
"RTN","PSOORFIN",45,0)
 .D KQ F  S ORD=$O(^PS(52.41,"AC",PAT,"W",ORD)) Q:'ORD!($G(POERR("QFLG")))  I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD
"RTN","PSOORFIN",46,0)
 .Q:$G(POERR("QFLG"))
"RTN","PSOORFIN",47,0)
 .D KQ F  S ORD=$O(^PS(52.41,"AC",PAT,"C",ORD)) Q:'ORD!($G(POERR("QFLG")))  D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD
"RTN","PSOORFIN",48,0)
 Q
"RTN","PSOORFIN",49,0)
C D KQ F  S ORD=$O(^PS(52.41,"AC",PAT,"C",ORD)) Q:'ORD!($G(POERR("QFLG")))  I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD S CLI=1
"RTN","PSOORFIN",50,0)
 Q:$G(POERR("QFLG"))  I $G(CLI) S ORD=0 D
"RTN","PSOORFIN",51,0)
 .D KQ F  S ORD=$O(^PS(52.41,"AC",PAT,"M",ORD)) Q:'ORD!($G(POERR("QFLG")))  I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD
"RTN","PSOORFIN",52,0)
 .Q:$G(POERR("QFLG"))
"RTN","PSOORFIN",53,0)
 .D KQ F  S ORD=$O(^PS(52.41,"AC",PAT,"W",ORD)) Q:'ORD!($G(POERR("QFLG")))  D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD
"RTN","PSOORFIN",54,0)
 Q
"RTN","PSOORFIN",55,0)
PAT W ! K MEDP,MEDA,POERR("DFLG"),DIR D KQ S PSOSORT="PATIENT"
"RTN","PSOORFIN",56,0)
 S DIR("?")="^D PT^PSOORFI1",DIR("A")="All Patients or Single Patient",DIR(0)="SBM^A:ALL;S:SINGLE;E:EXIT",DIR("B")="SINGLE"
"RTN","PSOORFIN",57,0)
 D ^DIR K DIR G:$D(DIRUT)!(Y="E") EX I Y="S" S PSOSORT=PSOSORT_"^"_"SINGLE" G SPAT
"RTN","PSOORFIN",58,0)
 S PSOSORT=PSOSORT_"^ALL"
"RTN","PSOORFIN",59,0)
 S LG=0,PATA=0 F  S LG=$O(^PS(52.41,"AD",LG)) Q:'LG!($G(POERR("QFLG")))  F PSOD=0:0 S PSOD=$O(^PS(52.41,"AD",LG,PSOPINST,PSOD)) Q:'PSOD!($G(POERR("QFLG")))  D
"RTN","PSOORFIN",60,0)
 .Q:'$D(^PS(52.41,PSOD,0))!($P($G(^PS(52.41,PSOD,0)),"^",23))
"RTN","PSOORFIN",61,0)
 .Q:$G(PAT($P(^PS(52.41,PSOD,0),"^",2)))=$P(^PS(52.41,PSOD,0),"^",2)  S PAT=$P(^PS(52.41,PSOD,0),"^",2)
"RTN","PSOORFIN",62,0)
 .;PSO*7*266
"RTN","PSOORFIN",63,0)
 .I PAT'=PATA D LBL
"RTN","PSOORFIN",64,0)
 .D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q
"RTN","PSOORFIN",65,0)
 .I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG,PSOQQ Q
"RTN","PSOORFIN",66,0)
 .S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT
"RTN","PSOORFIN",67,0)
 .D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) D SPL D OERR^PSORX1 S PSOFIN=1 D QU S X=PSOPTLOK D KLLP,ULP,KLL Q
"RTN","PSOORFIN",68,0)
 .D SDFN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG Q
"RTN","PSOORFIN",69,0)
 .S PAT(PAT)=PAT
"RTN","PSOORFIN",70,0)
 .F ORD=0:0 S ORD=$O(^PS(52.41,"AOR",PAT,PSOPINST,ORD)) Q:'ORD!($G(POERR("QFLG")))!($G(PSOQQ))  D
"RTN","PSOORFIN",71,0)
 ..I '$P($G(^PS(52.41,ORD,0)),"^",23) D PP,LK1,ORD
"RTN","PSOORFIN",72,0)
 .S X=PAT D ULP K PSOQQ
"RTN","PSOORFIN",73,0)
 I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL
"RTN","PSOORFIN",74,0)
 I $G(PSOQUIT) K PSOQUIT D EX G PSOORFIN
"RTN","PSOORFIN",75,0)
 G EX
"RTN","PSOORFIN",76,0)
 ;PSO*7*266 kill BINGCRT,BINGRTE when selecting pat.
"RTN","PSOORFIN",77,0)
SPAT K MEDA,MEDP,PSOQFLG,PSORX("FN"),BINGCRT,BINGRTE D KQ,KV^PSOVER1
"RTN","PSOORFIN",78,0)
 S DIR(0)="FO^2:30",DIR("A")="Select Patient",DIR("?")="^D HELP^PSOORFI2" D ^DIR I $E(X)="?" G SPAT
"RTN","PSOORFIN",79,0)
 G:$D(DIRUT) EX D KV^PSOVER1
"RTN","PSOORFIN",80,0)
 S DIC(0)="EQM",DIC=2,DIC("S")="I $D(^PS(52.41,""AOR"",+Y,PSOPINST))"
"RTN","PSOORFIN",81,0)
 D ^DIC K DIC G:"^"[X EX G:Y=-1 SPAT S (PSODFN,PAT)=+Y,PSOFINY=Y
"RTN","PSOORFIN",82,0)
 D LK I $G(POERR("QFLG")) G SPAT
"RTN","PSOORFIN",83,0)
 N SNGLPAT S SNGLPAT=1
"RTN","PSOORFIN",84,0)
 ;PSO*7*266
"RTN","PSOORFIN",85,0)
 D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSOFINY I $G(MEDP) D SPL D OERR^PSORX1 D LBL S PSOFIN=1,X=PSOPTLOK D KLLP,ULP,KLL G SPAT
"RTN","PSOORFIN",86,0)
 D PP,SDFN,POST^PSOORFI1 D:$G(PSOQFLG)  G:$G(PSOQFLG) EX I $G(PSOQUIT) S:$G(PSOQUIT) POERR("QFLG")=1 S X=PAT D ULP G SPAT
"RTN","PSOORFIN",87,0)
 .S X=PAT D ULP
"RTN","PSOORFIN",88,0)
 S ORD=0 F  S ORD=$O(^PS(52.41,"P",PAT,ORD)) Q:'ORD!($G(POERR("QFLG")))  D:'$P($G(^PS(52.41,ORD,0)),"^",23)
"RTN","PSOORFIN",89,0)
 .D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE")&($P(^(0),"^",3)'="HD") LK1,ORD
"RTN","PSOORFIN",90,0)
 ;PSO*7*266
"RTN","PSOORFIN",91,0)
 D LBL
"RTN","PSOORFIN",92,0)
 S PSOFIN=1,X=PAT D ULP G SPAT
"RTN","PSOORFIN",93,0)
ORD I $G(PSOBCK) N LST,ORN
"RTN","PSOORFIN",94,0)
 E  S PSOLOUD=1 D:$P($G(^PS(55,PAT,0)),"^",6)'=2 EN^PSOHLUP(PAT) K PSOLOUD
"RTN","PSOORFIN",95,0)
 K DRET,SIG,^TMP("PSORXDC",$J) Q:'$D(^PS(52.41,ORD,0))
"RTN","PSOORFIN",96,0)
 I $G(PSOFIN),$P($G(^PS(52.41,ORD,"INI")),"^")'=$G(PSOPINST) Q
"RTN","PSOORFIN",97,0)
 D L1^PSOORFI3 I '$G(PSOMSG) K PSOMSG Q
"RTN","PSOORFIN",98,0)
 I '$D(^PS(52.41,ORD,0)) K PSOMSG Q
"RTN","PSOORFIN",99,0)
 K DRET,SIG,PSOPRC,PHI,PRC,PSOSIGFL,OBX,PSOMSG S OR0=^PS(52.41,ORD,0)
"RTN","PSOORFIN",100,0)
 I $P(OR0,"^",24),($P(OR0,"^",3)="RNW"!($P(OR0,"^",3)="NW")) N PKI,PKI1,PKIR,PKIE,PKID S PKI=0 D CER^PSOPKIV1 I PKI<1 D UL1^PSOORFI3 K OR0 Q
"RTN","PSOORFIN",101,0)
 S PSOFDR=1,OI=$P(OR0,"^",8),PSORX("SC")=$P(OR0,"^",16)
"RTN","PSOORFIN",102,0)
 I $O(^PS(52.41,ORD,2,0)) S PHI=^PS(52.41,ORD,2,0),T=0 F  S T=$O(^PS(52.41,ORD,2,T)) Q:'T  S PHI(T)=^PS(52.41,ORD,2,T,0)
"RTN","PSOORFIN",103,0)
 I $P($G(^PS(52.41,ORD,"EXT")),"^")'="" K PHI I $O(^PS(52.41,ORD,"SIG",0)) S PHI=$G(^PS(52.41,ORD,"SIG",0)),T=0 F  S T=$O(^PS(52.41,ORD,"SIG",T)) Q:'T  S PHI(T)=$G(^PS(52.41,ORD,"SIG",T,0))
"RTN","PSOORFIN",104,0)
 I $O(^PS(52.41,ORD,3,0)) S PRC=^PS(52.41,ORD,3,0),T=0 F  S T=$O(^PS(52.41,ORD,3,T)) Q:'T  S PRC(T)=^PS(52.41,ORD,3,T,0)
"RTN","PSOORFIN",105,0)
 I $P(OR0,"^",3)="RNW",$D(^PSRX(+$P(OR0,"^",21),0)) D  G SUCC ;process renews
"RTN","PSOORFIN",106,0)
 .K PSOREEDT S (PSOORRNW,PSOFDR)=1,PSORENW("OIRXN")=$P(OR0,"^",21),PSOOPT=3,(PSORENW("DFLG"),PSORENW("QFLG"))=0 D ^PSOORRNW,SQR
"RTN","PSOORFIN",107,0)
 I $P(OR0,"^",3)="RF",$D(^PSRX(+$P(OR0,"^",19),0)) D RF^PSOORFI2 G SUCC
"RTN","PSOORFIN",108,0)
 N PSODRUG,PSONEW S PSOFROM="PENDING" D:'$G(PSOTPBFG) DSPL^PSOTPCAN(ORD) D DSPL^PSOORFI1,SQN^PSOORFI3
"RTN","PSOORFIN",109,0)
SUCC ;
"RTN","PSOORFIN",110,0)
 D UL1^PSOORFI3,FULL^VALM1
"RTN","PSOORFIN",111,0)
 D:$P($G(^PS(52.41,+$G(ORD),0)),"^",3)'="NW"&($P($G(^(0)),"^",3)'="RNW")&($P($G(^(0)),"^",3)'="HD")&($P($G(^(0)),"^",3)'="RF")
"RTN","PSOORFIN",112,0)
 .K PSOSD("PENDING",$S('$G(OID):$P(^PS(50.7,$P(OR0,"^",8),0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,$P(OR0,"^",8),0),"^",2),0),"^"),1:$P(^PSDRUG($P(OR0,"^",9),0),"^")))
"RTN","PSOORFIN",113,0)
 S:$G(POERR("DFLG")) POERR("QFLG")=1 K POERR("DFLG"),PSONEW,ACP,OR0,DRET,SIG,OID,OI,PSORX("SC"),PSORX("CLINIC"),PSODRUG
"RTN","PSOORFIN",114,0)
 Q
"RTN","PSOORFIN",115,0)
 ;PSO*7*266 change order of bingo checks.
"RTN","PSOORFIN",116,0)
LBL I $O(PSORX("PSOL",0))!($D(RXRS)) S PSOFROM="NEW" D ^PSORXL K PSORX("PSOL"),PPL,RXRS
"RTN","PSOORFIN",117,0)
 D:$D(BINGCRT)&($D(BINGRTE)&($D(DISGROUP))) ^PSOBING1 K BINGCRT,BINGRTE,PSONEW,BBFLG,BBRX
"RTN","PSOORFIN",118,0)
 Q
"RTN","PSOORFIN",119,0)
CHK ;
"RTN","PSOORFIN",120,0)
 D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) W !,$C(7),"Outpatient Division MUST be selected!",! G EX
"RTN","PSOORFIN",121,0)
 D INST1^PSOORFI2
"RTN","PSOORFIN",122,0)
 S PSZCNT=0 F PSZZI=0:0 S PSZZI=$O(^PS(59,PSZZI)) Q:'PSZZI  S PSZCNT=PSZCNT+1
"RTN","PSOORFIN",123,0)
 S TC=0 F TO=0:0 S TO=$O(^PS(52.41,"AOR",TO)) Q:'TO  F TZ=0:0 S TZ=$O(^PS(52.41,"AOR",TO,TZ)) Q:'TZ  F PSTZ=0:0 S PSTZ=$O(^PS(52.41,"AOR",TO,TZ,PSTZ)) Q:'PSTZ  S TC=TC+1
"RTN","PSOORFIN",124,0)
 W !!?10,$C(7),"Orders to be completed"_$S(PSZCNT=1:": ",1:" for all divisions: ")_TC,! Q:'TC
"RTN","PSOORFIN",125,0)
 D SUMM^PSOORNE1 K PSZZI,PSZCNT,PSTZ
"RTN","PSOORFIN",126,0)
 Q
"RTN","PSOORFIN",127,0)
 ;
"RTN","PSOORFIN",128,0)
LK D LOCK^PSOORFI1
"RTN","PSOORFIN",129,0)
 Q
"RTN","PSOORFIN",130,0)
LK1 D LOCK1^PSOORFI1 Q
"RTN","PSOORFIN",131,0)
QU I $G(PSOQUIT) S POERR("QFLG")=1 K PSOQUIT
"RTN","PSOORFIN",132,0)
 S:$G(PSOQFLG) PAT(PAT)=PAT
"RTN","PSOORFIN",133,0)
 Q
"RTN","PSOORFIN",134,0)
ULP K PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP")
"RTN","PSOORFIN",135,0)
 D CLEAN^PSOVER1
"RTN","PSOORFIN",136,0)
 I '$G(X) Q
"RTN","PSOORFIN",137,0)
 D UL^PSSLOCK(X) Q
"RTN","PSOORFIN",138,0)
KLL K PSOPTLOK Q
"RTN","PSOORFIN",139,0)
KLLP K PSONOLCK Q
"RTN","PSOORFIN",140,0)
SPL D SPL^PSOORFI4 Q
"RTN","PSOORFIN",141,0)
SDFN S PSODFN=+$G(PSODFN) Q
"RTN","PSOORFIN",142,0)
PP D PP^PSOORFI4 Q
"RTN","PSOORFIN",143,0)
KQ K PSOQUIT,POERR("QFLG") Q
"RTN","PSOORFIN",144,0)
SQR ;
"RTN","PSOORFIN",145,0)
 K PSOORRNW,PSOOPT,PSOREEDT,PSOQUIT,VALMSG S POERR("DFLG")=0
"RTN","PSOORFIN",146,0)
 Q
"RTN","PSOORNE2")
0^24^B69776712^B68864998
"RTN","PSOORNE2",1,0)
PSOORNE2 ;BIR/SAB-display finished orders from backdoor ;9/11/06 10:24am
"RTN","PSOORNE2",2,0)
 ;;7.0;OUTPATIENT PHARMACY;**11,21,23,27,32,37,46,84,103,117,131,146,156,210,148,222,238,264,281,289,251,379,391**;DEC 1997;Build 13
"RTN","PSOORNE2",3,0)
 ;^PSDRUG( -  221
"RTN","PSOORNE2",4,0)
 ;^YSCL(603.01 - 2697
"RTN","PSOORNE2",5,0)
 ;^PS(50.606 - 2174
"RTN","PSOORNE2",6,0)
 ;^PS(50.7 - 2223
"RTN","PSOORNE2",7,0)
 ;PSO*210 add call to WORDWRAP api
"RTN","PSOORNE2",8,0)
 ;$$DAWEXT^PSSDAWUT - 4708
"RTN","PSOORNE2",9,0)
 ;
"RTN","PSOORNE2",10,0)
SEL N ORN,ORD I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q
"RTN","PSOORNE2",11,0)
 D K1^PSOORNE6 S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR I $D(DIRUT) D KV^PSOVER1 S VALMBCK="" Q
"RTN","PSOORNE2",12,0)
NEWSEL N ORN,ORD D K2^PSOORNE6
"RTN","PSOORNE2",13,0)
 ;
"RTN","PSOORNE2",14,0)
 I +Y S PSOOELSE=1,PSLST=Y K PSOREEDT F ORD=1:1:$L(PSLST,",") Q:$P(PSLST,",",ORD)']""  D  D UL1 K ^TMP("PSORXPO",$J) I $G(PSOQUIT) K PSOQUIT Q
"RTN","PSOORNE2",15,0)
 .S ORN=+$P(PSLST,",",ORD) D @$S(+PSOLST(ORN)=52:"ACT",1:"PEN^PSOORNE5")
"RTN","PSOORNE2",16,0)
 .K PSOREEDT,PSOSIGFL,PSONACT,SIGOK,PSOFDR,DRET,SIG,INS1
"RTN","PSOORNE2",17,0)
 K PRC,PHI,RTE I '$G(PSOOELSE) S VALMBCK=""
"RTN","PSOORNE2",18,0)
 K PSONACT,PSOOELSE,CLOZPAT D ^PSOBUILD,BLD^PSOORUT1,K3^PSOORNE6
"RTN","PSOORNE2",19,0)
 Q
"RTN","PSOORNE2",20,0)
 ;
"RTN","PSOORNE2",21,0)
ACT N REF,RPHKEY,PKIND K ^TMP("PSOAO",$J),PCOMX,PDA,PHI,PRC,ACOM,ANS,PSOFDR,CLOZPAT,ANQREM,DUR,DRET
"RTN","PSOORNE2",22,0)
 S RXN=$P(PSOLST(ORN),"^",2),RX0=^PSRX(RXN,0),RX2=$G(^(2)),RX3=$G(^(3)),ST=+$G(^("STA")),RXOR=$G(^("OR1")),POE=$G(^("POE")),EXDT=$S($P($G(^(2)),"^",6)>DT:1,1:0)
"RTN","PSOORNE2",23,0)
 I 'RX3 S RX3=$P(RX2,"^",2),$P(^PSRX(RXN,3),"^")=$P(RX2,"^",2)
"RTN","PSOORNE2",24,0)
 S PSODRG=+$P(RX0,"^",6),PSODRUG0=^PSDRUG(PSODRG,0),INDT=$G(^("I"))
"RTN","PSOORNE2",25,0)
 ;PSO*7*238;SET PSODRUG ARRAY ; PSOY KILLED AT END OF SET^PSODRG
"RTN","PSOORNE2",26,0)
 K PSODRUG
"RTN","PSOORNE2",27,0)
 S PSOY=PSODRG,PSOY(0)=PSODRUG0 D SET^PSODRG
"RTN","PSOORNE2",28,0)
 I 'RXOR,$P(^PSDRUG(PSODRG,2),"^") S $P(^PSRX(RXN,"OR1"),"^")=$P(^PSDRUG(PSODRG,2),"^"),RXOR=$P(^PSDRUG(PSODRG,2),"^")
"RTN","PSOORNE2",29,0)
 I $P($G(^PSDRUG(PSODRG,"CLOZ1")),"^")="PSOCLO1" D
"RTN","PSOORNE2",30,0)
 .S CLOZPAT=$O(^YSCL(603.01,"C",PSODFN,0)) Q:'CLOZPAT
"RTN","PSOORNE2",31,0)
 .;S CLOZPAT=$S($P(^YSCL(603.01,CLOZPAT,0),"^",3)="B":1,1:0)
"RTN","PSOORNE2",32,0)
 .S CLOZPAT=$P(^YSCL(603.01,CLOZPAT,0),"^",3)
"RTN","PSOORNE2",33,0)
 .S CLOZPAT=$S(CLOZPAT="M":2,CLOZPAT="B":1,1:0)
"RTN","PSOORNE2",34,0)
 S PKIND=$D(^PSRX(RXN,"PKI")),RPHKEY=$S('PKIND&($D(^XUSEC("PSORPH",DUZ))):1,PKIND&($D(^XUSEC("PSDRPH",DUZ))):1,1:0)
"RTN","PSOORNE2",35,0)
 I RPHKEY S RPH=1 D
"RTN","PSOORNE2",36,0)
 .S PSOACT=$S('ST&($G(INDT)]"")&(DT>$G(INDT)):"DHPLATC",ST=1!(ST=4):"DVE",ST=3:"DU",ST=5:"ELTD",ST=11:"ETDPCL",ST=12&EXDT:"EDCL",ST=12&'EXDT:"ECL",(ST=14!(ST=15))&'EXDT:"ECL",ST=13:"L",ST=16:"DL",1:"DHPEATCL")
"RTN","PSOORNE2",37,0)
 .D GET^PSOORNE5 S PSOACT=PSOACT_$S(ACTREN:"N",1:""),PSOACT=PSOACT_$S(ACTREF:"R",1:"")
"RTN","PSOORNE2",38,0)
 .I ST=5 S SURX=$O(^PS(52.5,"B",RXN,0)) I SURX,$P($G(^PS(52.5,SURX,0)),"^",7)="L" S PSOACT="TL" K SURX Q
"RTN","PSOORNE2",39,0)
 .S:ST'=12&('$D(^PS(50.7,+$P(RXOR,"^"),0))) PSOACT="DL",VALMSG="No Pharmacy Orderable Item !",PSONACT=1
"RTN","PSOORNE2",40,0)
 .S:ST=12&('$D(^PS(50.7,+$P(RXOR,"^"),0))) PSOACT="L",VALMSG="No Pharmacy Orderable Item !",PSONACT=1
"RTN","PSOORNE2",41,0)
 .;I ST=14!(ST=15) S VALMSG="Rx Discontinued By "_$S(ST=14:"Provider",1:"Edit")_". Cannot be Reinstated."
"RTN","PSOORNE2",42,0)
 .S:ST=16 VALMSG="Rx Placed on HOLD by Provider."
"RTN","PSOORNE2",43,0)
 E  D
"RTN","PSOORNE2",44,0)
 .I ST=5 S SURX=$O(^PS(52.5,"B",RXN,0)) I SURX,$P($G(^PS(52.5,SURX,0)),"^",7)="L" S PSOACT="TL" Q
"RTN","PSOORNE2",45,0)
 .S PSOACT=$S(ST'<1&(ST'>4)!(ST>12):"",ST=12&EXDT&($P($G(PSOPAR),"^",2)):"CDPLT",1:"CPLT")
"RTN","PSOORNE2",46,0)
 .D GET^PSOORNE5 S PSOACT=PSOACT_$S(ACTREN:"N",1:""),PSOACT=PSOACT_$S(ACTREF:"R",1:"")
"RTN","PSOORNE2",47,0)
 .S:'$D(^PS(50.7,+$P(RXOR,"^"),0)) PSOACT="L",PSONACT=1,VALMSG="No Pharmacy Orderable Item !"
"RTN","PSOORNE2",48,0)
 ;K PSOLKFL D PSOL^PSSLOCK(RXN) I '$G(PSOMSG) K PSOMSG S PSOLKFL=1 S PSOACT="",VALMSG="This Order is being edited by another user."
"RTN","PSOORNE2",49,0)
 K PSOMSG S IEN=0,$P(RN," ",12)=" "
"RTN","PSOORNE2",50,0)
 D DIN^PSONFI(+RXOR,$P(RX0,"^",6))
"RTN","PSOORNE2",51,0)
 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=$S($P($G(^PSRX(RXN,"TPB")),"^"):"            TPB Rx #: ",1:"                Rx #: ")
"RTN","PSOORNE2",52,0)
 S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_$P(RX0,"^")_$S($G(^PSRX(RXN,"IB")):"$",1:"")_$$ECME^PSOBPSUT(RXN)_$E(RN,$L($P(RX0,"^")_$S($G(^PSRX(RXN,"IB")):"$",1:"")_$$ECME^PSOBPSUT(RXN))+1,12)
"RTN","PSOORNE2",53,0)
 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" ("_$S($P(PSOPAR,"^",3):1,1:"#")_")"_" *Orderable Item: "_$S($D(^PS(50.7,$P(+RXOR,"^"),0)):$P(^PS(50.7,$P(+RXOR,"^"),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^"),1:"")_NFIO
"RTN","PSOORNE2",54,0)
 S:NFIO["<DIN>" NFIO=IEN_","_($L(^TMP("PSOAO",$J,IEN,0))-4)
"RTN","PSOORNE2",55,0)
 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" ("_$S($P(PSOPAR,"^",3):2,1:"#")_")"_$S($D(^PSDRUG("AQ",$P(RX0,"^",6))):"       CMOP ",1:"            ")_"Drug: "_$P(^PSDRUG($P(RX0,"^",6),0),"^")_NFID
"RTN","PSOORNE2",56,0)
 S:NFID["<DIN>" NFID=IEN_","_($L(^TMP("PSOAO",$J,IEN,0))-4)
"RTN","PSOORNE2",57,0)
 I $$STATUS^PSOBPSUT(RXN,0)'="",$$RXRLDT^PSOBPSUT(RXN,0) D
"RTN","PSOORNE2",58,0)
 . S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" "_$S('$P(PSOPAR,"^",3):"(2)",1:"   ")_"             NDC: "_$$GETNDC^PSONDCUT(RXN,0)
"RTN","PSOORNE2",59,0)
 S:$G(^PSRX(RXN,"TN"))]"" IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="          Trade Name: "_$G(^PSRX(RXN,"TN"))
"RTN","PSOORNE2",60,0)
 D DOSE^PSOORNE5
"RTN","PSOORNE2",61,0)
 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" (4)Pat Instructions:" D INS^PSOORNE5
"RTN","PSOORNE2",62,0)
 D PC^PSOORNE5
"RTN","PSOORNE2",63,0)
 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="                 SIG:"
"RTN","PSOORNE2",64,0)
 I '$P($G(^PSRX(RXN,"SIG")),"^",2) S SIGOK=0 D  G PTST
"RTN","PSOORNE2",65,0)
 .S X=$P($G(^PSRX(RXN,"SIG")),"^") D SIGONE^PSOHELP S SIG=$E($G(INS1),2,250)
"RTN","PSOORNE2",66,0)
 .F SG=1:1:$L(SIG) S:$L(^TMP("PSOAO",$J,IEN,0)_" "_$P(SIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOAO",$J,IEN,0)," ",21)=" " S:$P(SIG," ",SG)'="" ^TMP("PSOAO",$J,IEN,0)=$G(^TMP("PSOAO",$J,IEN,0))_" "_$P(SIG," ",SG)
"RTN","PSOORNE2",67,0)
 S SIGOK=1
"RTN","PSOORNE2",68,0)
 F I=0:0 S I=$O(^PSRX(RXN,"SIG1",I)) Q:'I  D                  ;PSO*210
"RTN","PSOORNE2",69,0)
 . S MIG=$P(^PSRX(RXN,"SIG1",I,0),"^")
"RTN","PSOORNE2",70,0)
 . D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOAO",$J)),21)
"RTN","PSOORNE2",71,0)
 S SIGOK=1 K MIG,SG
"RTN","PSOORNE2",72,0)
PTST S $P(RN," ",25)=" ",PTST=$S($G(^PS(53,+$P(RX0,"^",3),0))]"":$P($G(^PS(53,+$P(RX0,"^",3),0)),"^"),1:""),IEN=IEN+1
"RTN","PSOORNE2",73,0)
 S ^TMP("PSOAO",$J,IEN,0)=" (5)  Patient Status: "_PTST_$E(RN,$L(PTST)+1,25)
"RTN","PSOORNE2",74,0)
 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" (6)      Issue Date: "_$E($P(RX0,"^",13),4,5)_"/"_$E($P(RX0,"^",13),6,7)_"/"_$E($P(RX0,"^",13),2,3)
"RTN","PSOORNE2",75,0)
 S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_"               (7)  Fill Date: "_$E($P(RX2,"^",2),4,5)_"/"_$E($P(RX2,"^",2),6,7)_"/"_$E($P(RX2,"^",2),2,3)
"RTN","PSOORNE2",76,0)
 S ROU=$S($P(RX0,"^",11)="W":"Window",1:"Mail")
"RTN","PSOORNE2",77,0)
 S REFL=$P(RX0,"^",9),I=0 F  S I=$O(^PSRX(RXN,1,I)) Q:'I  S REFL=REFL-1,ROU=$S($P(^PSRX(RXN,1,I,0),"^",2)="W":"Window",1:"Mail")
"RTN","PSOORNE2",78,0)
 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="      Last Fill Date: "_$E($P(RX3,"^"),4,5)_"/"_$E($P(RX3,"^"),6,7)_"/"_$E($P(RX3,"^"),2,3)
"RTN","PSOORNE2",79,0)
 D CMOP^PSOORNE3
"RTN","PSOORNE2",80,0)
 S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_" ("_ROU_$S($G(PSOCMOP)]"":", "_PSOCMOP,1:"")_")" K ROU,PSOCMOP
"RTN","PSOORNE2",81,0)
 S IEN=IEN+1 I $P(RX2,"^",15) S ^TMP("PSOAO",$J,IEN,0)="   Returned to Stock: "_$E($P(RX2,"^",15),4,5)_"/"_$E($P(RX2,"^",15),6,7)_"/"_$E($P(RX2,"^",15),2,3)_$S($P(RX2,"^",14):" (Reprinted)",1:"")
"RTN","PSOORNE2",82,0)
 E  S ^TMP("PSOAO",$J,IEN,0)="   Last Release Date: " D
"RTN","PSOORNE2",83,0)
 .S RLD=$S($P(RX2,"^",13):$E($P(RX2,"^",13),4,5)_"/"_$E($P(RX2,"^",13),6,7)_"/"_$E($P(RX2,"^",13),2,3),1:"")
"RTN","PSOORNE2",84,0)
 .I $O(^PSRX(RXN,1,0)) F I=0:0 S I=$O(^PSRX(RXN,1,I)) Q:'I  D
"RTN","PSOORNE2",85,0)
 ..I $P(^PSRX(RXN,1,I,0),"^",18) S RLD=$E($P(^(0),"^",18),4,5)_"/"_$E($P(^(0),"^",18),6,7)_"/"_$E($P(^(0),"^",18),2,3)
"RTN","PSOORNE2",86,0)
 .S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_$S($G(RLD)]"":RLD,1:"        ")
"RTN","PSOORNE2",87,0)
 S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_"               (8)      Lot #: "_$P($G(RX2),"^",4)
"RTN","PSOORNE2",88,0)
 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="             Expires: "_$E($P(RX2,"^",6),4,5)_"/"_$E($P(RX2,"^",6),6,7)_"/"_$E($P(RX2,"^",6),2,3)
"RTN","PSOORNE2",89,0)
 S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_"                          MFG: "_$P($G(RX2),"^",8)
"RTN","PSOORNE2",90,0)
 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(9)      Days Supply: "_$P(RX0,"^",8)_$S($L($P(RX0,"^",8))=1:" ",1:"")
"RTN","PSOORNE2",91,0)
 S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_"                    (10)  QTY"_$S($P($G(^PSDRUG($P(RX0,"^",6),660)),"^",8)]"":" ("_$P($G(^PSDRUG($P(RX0,"^",6),660)),"^",8)_")",1:" (  )")_": "_$P(RX0,"^",7)
"RTN","PSOORNE2",92,0)
 I $P($G(^PSDRUG($P(RX0,"^",6),5)),"^")]"" D
"RTN","PSOORNE2",93,0)
 .S $P(RN," ",79)=" ",IEN=IEN+1
"RTN","PSOORNE2",94,0)
 .S ^TMP("PSOAO",$J,IEN,0)=$E(RN,$L("QTY DSP MSG: "_$P(^PSDRUG($P(RX0,"^",6),5),"^"))+1,79)_"QTY DSP MSG: "_$P(^PSDRUG($P(RX0,"^",6),5),"^") K RN
"RTN","PSOORNE2",95,0)
 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(11)    # of Refills: "_$P(RX0,"^",9)_$S($L($P(RX0,"^",9))=1:" ",1:"")_"                          Remaining: "_REFL
"RTN","PSOORNE2",96,0)
 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(12)        Provider: "_$S($D(^VA(200,$P(RX0,"^",4),0)):$P(^VA(200,$P(RX0,"^",4),0),"^"),1:"UNKNOWN")
"RTN","PSOORNE2",97,0)
 I +$P($G(^PSDRUG($P(RX0,"^",6),0)),"^",3)>1,+$P($G(^PSDRUG($P(RX0,"^",6),0)),"^",3)<6 D PRV^PSOORNE5
"RTN","PSOORNE2",98,0)
 I $P(RX3,"^",3) S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="        Cos-Provider: "_$P(^VA(200,$S($G(PSORX("COSIGNING PROVIDER")):PSORX("COSIGNING PROVIDER"),1:$P(RX3,"^",3)),0),"^")
"RTN","PSOORNE2",99,0)
 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(13)         Routing: "_$S($P(RX0,"^",11)="M":"MAIL",1:"WINDOW")_"                  (14)     Copies: "_$S($P(RX0,"^",18):$P(RX0,"^",18),1:1)
"RTN","PSOORNE2",100,0)
 S:$P(RX0,"^",11)="W"&($P(PSOPAR,"^",12)) IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="    Method of Pickup: "_$G(^PSRX(RXN,"MP"))
"RTN","PSOORNE2",101,0)
 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(15)          Clinic: "_$S($D(^SC(+$P(RX0,"^",5),0)):$P(^SC($P(RX0,"^",5),0),"^"),1:"Not on File")
"RTN","PSOORNE2",102,0)
 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(16)        Division: "_$S($G(^PS(59,+$P(RX2,"^",9),0))]"":$P(^PS(59,$P(RX2,"^",9),0),"^")_" ("_$P(^(0),"^",6)_")",1:"UNKNOWN")
"RTN","PSOORNE2",103,0)
 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(17)      Pharmacist: "_$S($P(RX2,"^",3):$P(^VA(200,$P(RX2,"^",3),0),"^"),1:"")
"RTN","PSOORNE2",104,0)
 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(18)         Remarks:" D RMK^PSOORNE3
"RTN","PSOORNE2",105,0)
 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(19)      Counseling: "_$S($P($G(^PSRX(RXN,"PC")),"^"):"YES",1:"NO")_"                      "_$S($P($G(^PSRX(RXN,"PC")),"^"):"Was Counseling Understood: "_$S($P($G(^PSRX(RXN,"PC")),"^",2):"YES",1:"NO"),1:"")
"RTN","PSOORNE2",106,0)
 S:$O(^PSRX(RXN,1,0)) REF=1,IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(20)     Refill Data"
"RTN","PSOORNE2",107,0)
 I $$STATUS^PSOBPSUT(RXN,0)'="" D
"RTN","PSOORNE2",108,0)
 . N DAW S IEN=IEN+1,DAW=$$GETDAW^PSODAWUT(RXN,0)
"RTN","PSOORNE2",109,0)
 . S ^TMP("PSOAO",$J,IEN,0)="(21)        DAW Code: "_DAW_" - "_$$DAWEXT^PSSDAWUT(DAW)
"RTN","PSOORNE2",110,0)
 D DISP^PSOORNE6
"RTN","PSOORNE2",111,0)
 I $G(PSOBEDT),PSOACT["E" S PSOACT="E"
"RTN","PSOORNE2",112,0)
 I $G(PSOBEDT),PSOACT'["E" S PSOACT=""
"RTN","PSOORNE2",113,0)
 Q:$G(PSORXED)!($G(COPY))!($G(UPMI))
"RTN","PSOORNE2",114,0)
 S:$G(PSOBEDT) (PSOEDIT,PSORXED)=1
"RTN","PSOORNE2",115,0)
RENERR S PSORERR=0 D ^PSOLMLST ; I '$G(PSOLKFL) D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2))
"RTN","PSOORNE2",116,0)
 I PSORERR=1 S:$G(PSOBEDT) (PSOEDIT,PSORXED)=1 G RENERR
"RTN","PSOORNE2",117,0)
 K DRET,SIG
"RTN","PSOORNE2",118,0)
 Q
"RTN","PSOORNE2",119,0)
UL1 ;
"RTN","PSOORNE2",120,0)
 ;I +PSOLST(ORN)=52 D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) Q
"RTN","PSOORNE2",121,0)
 ;I $D(^PS(52.41,$P(PSOLST(ORN),"^",2),0)) D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)_"S")
"RTN","PSOORNE2",122,0)
 Q
"RTN","PSOORNE3")
0^25^B68130643^B66896129
"RTN","PSOORNE3",1,0)
PSOORNE3 ;ISC-BHAM/SAB - display pending orders from backdoor ;2/3/05 1:59pm
"RTN","PSOORNE3",2,0)
 ;;7.0;OUTPATIENT PHARMACY;**11,9,39,59,46,103,124,139,152,194,391**;DEC 1997;Build 13
"RTN","PSOORNE3",3,0)
 ;Ext ref to ^SC (File #44) (DBIA 10040),^PSXOPUTL (DBIA 2200)
"RTN","PSOORNE3",4,0)
 ;^PS(50.606 (DBIA 2174),^PS(50.7 DBIA 2223),^PS(55,DBIA 2228)
"RTN","PSOORNE3",5,0)
 ;^PSDRUG (DBIA 221)
"RTN","PSOORNE3",6,0)
 K ^TMP("PSOPO",$J) S ORD=$P(PSOLST(ORN),"^",2) D ORD^PSOORFIN Q
"RTN","PSOORNE3",7,0)
 S PSODRUG("OI")=$P(OR0,"^",8),PSODRUG("OIN")=$P(^PS(50.7,$P(OR0,"^",8),0),"^")
"RTN","PSOORNE3",8,0)
 I $P($G(OR0),"^",9) S DREN=$P(OR0,"^",9) S POERR=1 D DRG^PSOORDRG K POERR ;D POST^PSODRG
"RTN","PSOORNE3",9,0)
 I '$P(OR0,"^",9) D DREN^PSOORNW2
"RTN","PSOORNE3",10,0)
 S PSONEW("# OF REFILLS")=$P(OR0,"^",11)
"RTN","PSOORNE3",11,0)
 S (Y,PSONEW("ISSUE DATE"))=$S($G(PSONEW("ISSUE DATE")):PSONEW("ISSUE DATE"),1:$E($P(OR0,"^",6),1,7)) X ^DD("DD")
"RTN","PSOORNE3",12,0)
 S PSONEW("CLERK CODE")=$P(OR0,"^",4),PSORX("CLERK CODE")=$P(^VA(200,$P(OR0,"^",4),0),"^")
"RTN","PSOORNE3",13,0)
 S (PSONEW("DFLG"),PSONEW("QFLG"))=0,PSODFN=$P(OR0,"^",2),PSONEW("QTY")=$P(OR0,"^",10),PSONEW("MAIL/WINDOW")=$S($P(OR0,"^",17)]"":$P(OR0,"^",17),1:"W")
"RTN","PSOORNE3",14,0)
 S:$G(PSONEW("CLINIC"))']"" PSONEW("CLINIC")=$P(OR0,"^",13)
"RTN","PSOORNE3",15,0)
 S:$G(PSORX("CLINIC"))']"" PSORX("CLINIC")=$S($D(^SC(+$P(OR0,"^",13),0)):$P(^SC($P(OR0,"^",13),0),"^"),1:"")
"RTN","PSOORNE3",16,0)
 S PSONEW("CLERK CODE")=$P(OR0,"^",4),PSONEW("PROVIDER")=$P(OR0,"^",5),PSONEW("PROVIDER NAME")=$P(^VA(200,$P(OR0,"^",5),0),"^")
"RTN","PSOORNE3",17,0)
 S PSONEW("PATIENT STATUS")=$S(+$G(^PS(55,PSODFN,"PS")):+$G(^PS(55,PSODFN,"PS")),1:"")
"RTN","PSOORNE3",18,0)
 S PSONEW("DAYS SUPPLY")=$S(+$G(^PS(55,PSODFN,"PS"))&($P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",3)):$P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",3),1:30)
"RTN","PSOORNE3",19,0)
 S IEN=0 D OBX^PSOORFI1,DIN^PSONFI(PSODRUG("OI"),$S($G(PSODRUG("IEN")):PSODRUG("IEN"),1:"")) ;Setup for N/F & DIN indicator
"RTN","PSOORNE3",20,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="* (1) Orderable Item: "_$P(^PS(50.7,PSODRUG("OI"),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")_NFIO
"RTN","PSOORNE3",21,0)
 S:NFIO["DIN" NFIO=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4)
"RTN","PSOORNE3",22,0)
 K LST S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (2)           Drug: "_$S($G(PSODRUG("NAME"))]"":PSODRUG("NAME")_NFID,1:"No Dispense Drug Selected")
"RTN","PSOORNE3",23,0)
 S:NFID["DIN" NFID=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4)
"RTN","PSOORNE3",24,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (3) Patient Status: "_$P($G(^PS(53,PSONEW("PATIENT STATUS"),0)),"^")
"RTN","PSOORNE3",25,0)
 S IEN=IEN+1,(PSOID,Y)=$E($P(OR0,"^",6),1,7) X ^DD("DD") S ^TMP("PSOPO",$J,IEN,0)="   (4)     Issue Date: "_Y
"RTN","PSOORNE3",26,0)
 S (Y,PSONEW("FILL DATE"))=$E($P(OR0,"^",6),1,7) X ^DD("DD") S PSONEW("FILL DATE")=Y,^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"                       (5) Fill Date: "_Y
"RTN","PSOORNE3",27,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="       Instructions:" S TY=3 D INST^PSOORFI1
"RTN","PSOORNE3",28,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (6)   Possible SIG: " D:$G(PSONEW("SIG"))']"" SIG^PSOORFI1 S:$G(PSONEW("SIG"))]"" IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=$G(PSONEW("SIG")),IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=PSOERR("SIG")
"RTN","PSOORNE3",29,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (7)    Days Supply: "_$S($G(PSONEW("DAYS SUPPLY")):PSONEW("DAYS SUPPLY"),+$G(^PS(55,PSODFN,"PS"))&($P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",3)):$P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",3),1:"")
"RTN","PSOORNE3",30,0)
 S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"                                 (8)     QTY: "_$P(OR0,"^",10)
"RTN","PSOORNE3",31,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (9)   # of Refills: "_$P(OR0,"^",11)_$E("  ",$L($P(OR0,"^",11))+1,2)_"                                (10) Routing: "_$S($G(PSONEW("MAIL/WINDOW"))="M":"MAIL",1:"WINDOW")
"RTN","PSOORNE3",32,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (11)         Clinic: "_PSORX("CLINIC")
"RTN","PSOORNE3",33,0)
 S $P(RN," ",32)=" ",IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (12)       Provider: "_PSONEW("PROVIDER NAME")_$E(RN,$L(PSONEW("PROVIDER NAME"))+1,32)_"  (13)  Copies: "_$S($G(PSONEW("COPIES")):PSONEW("COPIES"),1:1) K RN
"RTN","PSOORNE3",34,0)
 I $P(^VA(200,$S($G(PSONEW("PROVIDER")):PSONEW("PROVIDER"),1:$P(OR0,"^",5)),"PS"),"^",7)&($P(^("PS"),"^",8)) S IEN=IEN+1,PSONEW("COSIGNING PROVIDER")=$P(^("PS"),"^",8) D
"RTN","PSOORNE3",35,0)
 .S ^TMP("PSOPO",$J,IEN,0)="        Cos-Provider: "_$P(^VA(200,+$G(PSONEW("COSIGNING PROVIDER")),0),"^")
"RTN","PSOORNE3",36,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  Provider Comments:" S TY=2 D INST^PSOORFI1
"RTN","PSOORNE3",37,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (14)        Remarks: "
"RTN","PSOORNE3",38,0)
 I $G(PSONEW("REMARKS"))]"" D
"RTN","PSOORNE3",39,0)
 .F SG=1:1:$L(PSONEW("REMARKS")) S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(PSONEW("REMARKS")," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " D
"RTN","PSOORNE3",40,0)
 ..S:$P(PSONEW("REMARKS")," ",SG)'="" ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(PSONEW("REMARKS")," ",SG)
"RTN","PSOORNE3",41,0)
 S $P(RN," ",35)=" ",IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="   Entry By: "_$P(^VA(200,$P(OR0,"^",4),0),"^")_$E(RN,$L($P(^VA(200,$P(OR0,"^",4),0),"^"))+1,35)
"RTN","PSOORNE3",42,0)
 S Y=$P(OR0,"^",12) X ^DD("DD") S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"Entry Date: "_$E($P(OR0,"^",12),4,5)_"/"_$E($P(OR0,"^",12),6,7)_"/"_$E($P(OR0,"^",12),2,3)_" "_$P(Y,"@",2) K RN
"RTN","PSOORNE3",43,0)
 G ^PSOLMPO
"RTN","PSOORNE3",44,0)
 Q
"RTN","PSOORNE3",45,0)
DSPL ;backdoor
"RTN","PSOORNE3",46,0)
 K ^TMP("PSOPO",$J) D DIN^PSONFI(PSODRUG("OI"),$S($G(PSODRUG("IEN")):PSODRUG("IEN"),1:"")) ;NFI
"RTN","PSOORNE3",47,0)
 I $D(RX0),$D(PSODRUG("IEN")) D
"RTN","PSOORNE3",48,0)
 .I PSODRUG("IEN")=$P(RX0,"^",6)!($P(PSLST,",",2)) D RST
"RTN","PSOORNE3",49,0)
 S IEN=0,IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="      Orderable Item: "_$P(^PS(50.7,PSODRUG("OI"),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")_NFIO
"RTN","PSOORNE3",50,0)
 S:NFIO["DIN" NFIO=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4)
"RTN","PSOORNE3",51,0)
 I $G(PSODRUG("NAME"))]"" D  G PST
"RTN","PSOORNE3",52,0)
 .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (1)"_$S($D(^PSDRUG("AQ",PSODRUG("IEN"))):"      CMOP ",1:"           ")_"Drug: "_PSODRUG("NAME")_NFID
"RTN","PSOORNE3",53,0)
 .S:NFID["DIN" NFID=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4)
"RTN","PSOORNE3",54,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (1)           Drug: No Dispense Drug Selected"
"RTN","PSOORNE3",55,0)
PST S:$G(PSODRUG("TRADE NAME"))]"" IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="          Trade Name: "_$S($G(PSODRUG("TRADE NAME"))]"":PSODRUG("TRADE NAME"),1:"")
"RTN","PSOORNE3",56,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (2) Patient Status: "_$P($G(^PS(53,PSONEW("PATIENT STATUS"),0)),"^")
"RTN","PSOORNE3",57,0)
 I $G(PSOID) S Y=PSOID X ^DD("DD") S PSONEW("ISSUE DATE")=Y
"RTN","PSOORNE3",58,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (3)     Issue Date: "_PSONEW("ISSUE DATE")
"RTN","PSOORNE3",59,0)
 S X2=PSONEW("DAYS SUPPLY")*(PSONEW("# OF REFILLS")+1)\1
"RTN","PSOORNE3",60,0)
 S X1=$S($G(PSOID):PSOID,1:DT)
"RTN","PSOORNE3",61,0)
 S X2=$S(PSONEW("DAYS SUPPLY")=X2:X2,+$G(PSOX("CS")):184,1:366)
"RTN","PSOORNE3",62,0)
 I X2<30 D
"RTN","PSOORNE3",63,0)
 . N % S %=$P($G(PSORX("PATIENT STATUS")),"^"),X2=30
"RTN","PSOORNE3",64,0)
 . S:%?.N %=$P($G(^PS(53,+%,0)),"^") I %["AUTH ABS" S X2=5
"RTN","PSOORNE3",65,0)
 D C^%DTC I PSONEW("FILL DATE")>X S PSONEW("FILL DATE")=PSONEW("ISSUE DATE")
"RTN","PSOORNE3",66,0)
 S Y=PSONEW("FILL DATE") X ^DD("DD") S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"             (4) Fill Date: "_Y
"RTN","PSOORNE3",67,0)
 D DOSE^PSOBKDED
"RTN","PSOORNE3",68,0)
 I $G(PSORXED("IRXN")),'$G(PSOSIGFL) S RXN=PSORXED("IRXN") D:'$G(COPY) INST1^PSOORNE5 K RXN
"RTN","PSOORNE3",69,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="                 SIG:"
"RTN","PSOORNE3",70,0)
 I $G(SIGOK),$O(SIG(0)) D SIG G DSP
"RTN","PSOORNE3",71,0)
 I $D(PSOCOPY),$G(PSONEW("SIG"))']"" D SIG G DSP
"RTN","PSOORNE3",72,0)
 I $G(PSOSIGFL),$G(PSONEW("SIG"))']"" D SIG G DSP
"RTN","PSOORNE3",73,0)
 D:$G(PSONEW("SIG"))]""
"RTN","PSOORNE3",74,0)
 .S X=PSONEW("SIG") D SIGONE^PSOHELP S SIG=$E($G(INS1),2,250)
"RTN","PSOORNE3",75,0)
 .F SG=1:1:$L(SIG) S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(SIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",21)=" " S:$P(SIG," ",SG)'="" ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(SIG," ",SG)
"RTN","PSOORNE3",76,0)
DSP S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (7)    Days Supply: "_PSONEW("DAYS SUPPLY")_$S($L(PSONEW("DAYS SUPPLY"))=1:" ",1:"")
"RTN","PSOORNE3",77,0)
 I '$D(PSONEW("FLD")),$D(RX0) S PSONEW("QTY")=$P(RX0,"^",7)
"RTN","PSOORNE3",78,0)
 ;if sched PSONEW("FLD") not def. qty reset
"RTN","PSOORNE3",79,0)
 ;if qty PSONEW("FLD")=7, qty NOT reset
"RTN","PSOORNE3",80,0)
 S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"                     (8)   QTY"_$S($G(PSODRUG("UNIT"))]"":" ("_PSODRUG("UNIT")_")",1:" ( )")_": "_PSONEW("QTY")
"RTN","PSOORNE3",81,0)
 I $P($G(^PSDRUG(+$G(PSODRUG("IEN")),5)),"^")]"" D
"RTN","PSOORNE3",82,0)
 .S $P(RN," ",79)=" ",IEN=IEN+1
"RTN","PSOORNE3",83,0)
 .S ^TMP("PSOPO",$J,IEN,0)=$E(RN,$L("QTY DSP MSG: "_$P(^PSDRUG(PSODRUG("IEN"),5),"^"))+1,79)_"QTY DSP MSG: "_$P(^PSDRUG(PSODRUG("IEN"),5),"^") K RN
"RTN","PSOORNE3",84,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (9)   # of Refills: "_PSONEW("# OF REFILLS")_$S($L(PSONEW("# OF REFILLS"))=1:" ",1:"")_"                     (10)  Routing: "_$S($G(PSONEW("MAIL/WINDOW"))="M":"MAIL",1:"WINDOW")
"RTN","PSOORNE3",85,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (11)         Clinic: "_$S($G(PSONEW("CLINIC")):$P(^SC(PSONEW("CLINIC"),0),"^"),1:"")
"RTN","PSOORNE3",86,0)
 S $P(RN," ",31)=" ",IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (12)       Provider: "_PSONEW("PROVIDER NAME")_$E(RN,$L(PSONEW("PROVIDER NAME"))+1,31)_"(13)   Copies: "_$S($G(PSONEW("COPIES")):PSONEW("COPIES"),1:1) K RN
"RTN","PSOORNE3",87,0)
 I $G(PKI),+$G(PSODRUG("DEA"))>1,+$G(PSODRUG("DEA"))<6 D PRV^PSOORFI5($G(PSONEW("PROVIDER")),$G(PSODRUG("IEN")),$P(OR0,"^"))
"RTN","PSOORNE3",88,0)
 I $G(PSONEW("COSIGNING PROVIDER"))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="        Cos-Provider: "_$P(^VA(200,PSONEW("COSIGNING PROVIDER"),0),"^")
"RTN","PSOORNE3",89,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (14)        Remarks:"
"RTN","PSOORNE3",90,0)
 I $G(PSONEW("REMARKS"))]"" D
"RTN","PSOORNE3",91,0)
 .F SG=1:1:$L(PSONEW("REMARKS")) S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(PSONEW("REMARKS")," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",21)=" " D
"RTN","PSOORNE3",92,0)
 ..S:$P(PSONEW("REMARKS")," ",SG)'="" ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(PSONEW("REMARKS")," ",SG)
"RTN","PSOORNE3",93,0)
 I $G(PSORXED("IRXN")),'$G(PSOSIGFL) S RXN=PSORXED("IRXN") D:'$G(COPY) PC1^PSOORNE5 K RXN
"RTN","PSOORNE3",94,0)
 S $P(RN," ",35)=" ",IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="   Entry By: "_$P(^VA(200,DUZ,0),"^")_$E(RN,$L($P(^VA(200,DUZ,0),"^"))+1,35)
"RTN","PSOORNE3",95,0)
 D NOW^%DTC S PSONEW("LOGIN DATE")=% K %,X S Y=PSONEW("LOGIN DATE") X ^DD("DD")
"RTN","PSOORNE3",96,0)
 S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"Entry Date: "_$P(Y,"@")_" "_$P(Y,"@",2) K RN,PSOFDR
"RTN","PSOORNE3",97,0)
 S (VALMCNT,PSOPF)=IEN Q
"RTN","PSOORNE3",98,0)
SIG ;
"RTN","PSOORNE3",99,0)
 D SIG^PSOORNE6 Q
"RTN","PSOORNE3",100,0)
CMOP ;
"RTN","PSOORNE3",101,0)
 K PSXZ S X="PSXOPUTL" X ^%ZOSF("TEST") K X I  D
"RTN","PSOORNE3",102,0)
 .S DA=RXN D ^PSXOPUTL K DA,PSOCMOP
"RTN","PSOORNE3",103,0)
 .S PSOCMOP=$S($G(PSXZ(PSXZ("L")))=0!($G(PSXZ(PSXZ("L")))=2):"Transmitted",$G(PSXZ(PSXZ("L")))=1:"Released",$G(PSXZ(PSXZ("L")))=3:"Not Dispensed",1:"")
"RTN","PSOORNE3",104,0)
 .I $G(PSXZ(PSXZ("L")))=3 F LBL=0:0 S LBL=$O(^PSRX(RXN,"L",LBL)) Q:'LBL  I $P(^PSRX(RXN,"L",LBL,0),"^",2)=PSXZ("L"),'$P(^(0),"^",5),$P(^(0),"^",3)'["INTERACTION" S PSOCMOP="Local"
"RTN","PSOORNE3",105,0)
 .K PSXZ
"RTN","PSOORNE3",106,0)
 Q
"RTN","PSOORNE3",107,0)
RST ;
"RTN","PSOORNE3",108,0)
 S PSODRUG("IEN")=$P(RX0,"^",6),PSODRUG("OI")=$P(^PSDRUG(($P(RX0,"^",6)),2),"^")
"RTN","PSOORNE3",109,0)
 S PSODRUG("NAME")=$P(^PSDRUG(($P(RX0,"^",6)),0),"^")
"RTN","PSOORNE3",110,0)
 Q
"RTN","PSOORNE3",111,0)
RMK ;
"RTN","PSOORNE3",112,0)
 I $P(RX3,"^",7)]"" D
"RTN","PSOORNE3",113,0)
 .F SG=1:1:$L($P(RX3,"^",7)) S:$L(^TMP("PSOAO",$J,IEN,0)_" "_$P($P(RX3,"^",7)," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOAO",$J,IEN,0)," ",21)=" " D
"RTN","PSOORNE3",114,0)
 ..S:$P($P(RX3,"^",7)," ",SG)'="" ^TMP("PSOAO",$J,IEN,0)=$G(^TMP("PSOAO",$J,IEN,0))_" "_$P($P(RX3,"^",7)," ",SG)
"RTN","PSOORNE3",115,0)
 Q
"RTN","PSOORNE4")
0^23^B94257859^B85067804
"RTN","PSOORNE4",1,0)
PSOORNE4 ;BIR/SAB-display renew RXs from backdoor ;07/29/96
"RTN","PSOORNE4",2,0)
 ;;7.0;OUTPATIENT PHARMACY;**11,27,32,36,46,75,96,103,99,117,131,225,386,390,391**;DEC 1997;Build 13
"RTN","PSOORNE4",3,0)
 ;^SC DBIA-10040;^PS(50.7-2223;^PS(50.606-2174;^PS(50.607-2221;^PS(51.2-2226;^PSDRUG-221;^PS(55-2228
"RTN","PSOORNE4",4,0)
 ;External reference to EN1^ORCFLAG supported by DBIA 3620
"RTN","PSOORNE4",5,0)
 ;
"RTN","PSOORNE4",6,0)
EN(PSONEW) N FLD,LST,VALMCNT
"RTN","PSOORNE4",7,0)
EN1 K PSOQUIT D:$G(PSONEW("ENT"))'>0  I $G(PSORENW("POE"))=1 S PSOREEDT=1 D SV
"RTN","PSOORNE4",8,0)
 .S PSOREEDT=1 D SV
"RTN","PSOORNE4",9,0)
 .K PSONEW("DOSE"),PSONEW("UNITS"),PSONEW("DOSE ORDERED"),PSONEW("ROUTE")
"RTN","PSOORNE4",10,0)
 .K PSONEW("SCHEDULE"),PSONEW("DURATION"),PSONEW("CONJUNCTION"),PSONEW("NOUN"),PSONEW("VERB"),PSOPRC,PSONEW("ODOSE")
"RTN","PSOORNE4",11,0)
RDD D DSPL,^PSOLMRN D:$G(PKI1)=2 DCP^PSOPKIV1 I $G(PSORX("FN")) S VALMBCK="Q" K PSOREEDT Q
"RTN","PSOORNE4",12,0)
 G:'$G(PSOQUIT) RDD
"RTN","PSOORNE4",13,0)
 Q
"RTN","PSOORNE4",14,0)
EDT D KV^PSOVER1 S DIR("A")="Select Field to Edit by number",DIR(0)="LO^1:"_$S($G(PSOREEDT):10,1:8)
"RTN","PSOORNE4",15,0)
 D ^DIR I $D(DTOUT)!($D(DUOUT)) D KV^PSOVER1 S VALMBCK="" Q
"RTN","PSOORNE4",16,0)
EDTSEL S PSOLM=1,(PSONEW("DFLG"),PSONEW("FIELD"),PSONEW3)=0
"RTN","PSOORNE4",17,0)
 I +Y S LST=Y D HLDHDR^PSOLMUTL S PSOEDT=1 D  Q:$G(PSODIR("DFLG"))!($G(PSODIR("QFLG")))
"RTN","PSOORNE4",18,0)
 .F FLD=1:1:$L(LST,",") Q:$P(LST,",",FLD)']""  D @(+$P(LST,",",FLD)) Q:$G(PSODIR("DFLG"))!($G(PSODIR("QFLG")))
"RTN","PSOORNE4",19,0)
 E  S VALMBCK="" D FULL^VALM1
"RTN","PSOORNE4",20,0)
 Q
"RTN","PSOORNE4",21,0)
ACP ; Renewal Accept
"RTN","PSOORNE4",22,0)
 N DIR,Y,DIRUT,DUOUT,DTOUT,DIR S Y=0
"RTN","PSOORNE4",23,0)
 I $G(ORD),+$P($G(^PS(52.41,+ORD,0)),"^",23)=1 D  Q:$D(DIRUT)!'Y  D EN1^ORCFLAG(+$P($G(^PS(52.41,ORD,0)),"^")) H 1
"RTN","PSOORNE4",24,0)
 . D FULL^VALM1
"RTN","PSOORNE4",25,0)
 . I '$D(^XUSEC("PSORPH",DUZ)) D  S Y=0 Q
"RTN","PSOORNE4",26,0)
 . . S DIR("A",1)="Order must be unflagged by a pharmacist before it can be finished."
"RTN","PSOORNE4",27,0)
 . . S DIR("A",2)=""
"RTN","PSOORNE4",28,0)
 . . S DIR(0)="E",DIR("A")="Enter RETURN to continue" W !,$C(7) D ^DIR
"RTN","PSOORNE4",29,0)
 . . S VALMBCK="R"
"RTN","PSOORNE4",30,0)
 . D FULL^VALM1
"RTN","PSOORNE4",31,0)
 . S DIR("A",1)="This Order is flagged. In order to finish it"
"RTN","PSOORNE4",32,0)
 . S DIR("A",2)="you must unflag it first."
"RTN","PSOORNE4",33,0)
 . S DIR("A",3)=""
"RTN","PSOORNE4",34,0)
 . S DIR(0)="Y",DIR("A")="Unflag Order",DIR("B")="NO"
"RTN","PSOORNE4",35,0)
 . W ! D ^DIR I $D(DIRUT)!'Y S VALMBCK="Q"
"RTN","PSOORNE4",36,0)
 I $G(ORD),+$P($G(^PS(52.41,+ORD,0)),"^",23)=1 Q
"RTN","PSOORNE4",37,0)
 ;
"RTN","PSOORNE4",38,0)
 D INST2^PSORENW S PSOFROM1=1 D:$D(^XUSEC("PSORPH",DUZ))!('$P(PSOPAR,"^",2)) VER
"RTN","PSOORNE4",39,0)
 K PSOFROM1
"RTN","PSOORNE4",40,0)
PKI I $G(PSONEW("QFLG")) S POERR("DFLG")=1,VALMBCK="R" K PSONEW2 Q
"RTN","PSOORNE4",41,0)
 I PSONEW("ENT")>0,$G(NEWDOSE) K NEWDOSE G EN1 Q
"RTN","PSOORNE4",42,0)
 S PSORX("FN")=1 D EN^PSORN52(.PSONEW) D:$G(PKI)=89802020 ALERT^PSOPKIV1
"RTN","PSOORNE4",43,0)
 ;saves drug allergy order chks pso*7*390
"RTN","PSOORNE4",44,0)
 I +$G(^TMP("PSODAOC",$J,1,0)) D
"RTN","PSOORNE4",45,0)
 .I $G(PSORX("DFLG")) K ^TMP("PSODAOC",$J) Q
"RTN","PSOORNE4",46,0)
 .S RXN=PSORENW("IRXN"),PSODAOC="Finished CPRS Rx "_$S($P(^PSRX(RXN,"STA"),"^")=4:"NON-VERIFIED ",1:"")_"RENEW Order Acceptance_OP"
"RTN","PSOORNE4",47,0)
 .D DAOC^PSONEW
"RTN","PSOORNE4",48,0)
 D RNPSOSD^PSOUTIL,ACP1^PSOORNE6,^PSOBUILD S VALMBCK="Q"
"RTN","PSOORNE4",49,0)
 Q
"RTN","PSOORNE4",50,0)
VER1(PSONEW) ;
"RTN","PSOORNE4",51,0)
VER S (PSONEW("DFLG"),PSONEW("QFLG"))=0 I PSONEW("ENT")=0 D  K PSOORRNW,PSOFROM1 I PSONEW("DFLG")=1 S (PSONEW("QFLG"),POERR("DFLG"))=1 Q
"RTN","PSOORNE4",52,0)
 .S (PSOREEDT,PSOORRNW)=1 W !!,"Dosing Instruction Missing!!",!
"RTN","PSOORNE4",53,0)
 .S PSONEW("IRXN")=PSONEW("OIRXN") K VALMSG D FULL^VALM1 W !,"Drug: "_PSODRUG("NAME") D
"RTN","PSOORNE4",54,0)
 ..I $O(SIG(0)) D  Q
"RTN","PSOORNE4",55,0)
 ...F I=1:1 Q:$G(SIG(I))']""  W !,SIG(I)
"RTN","PSOORNE4",56,0)
 ..I $P($G(^PSRX(PSONEW("OIRXN"),"SIG")),"^")]"" S X=$P(^PSRX(PSONEW("OIRXN"),"SIG"),"^") D SIGONE^PSOHELP W !,$E($G(INS1),2,250)
"RTN","PSOORNE4",57,0)
 .K DIRUT W ! D DOSE^PSODIR(.PSONEW) Q:$G(PSONEW("DFLG"))  D EN^PSOFSIG(.PSONEW)
"RTN","PSOORNE4",58,0)
 .I PSONEW("ENT")>0,$O(SIG(0)) S (SIGOK,NEWDOSE)=1
"RTN","PSOORNE4",59,0)
 .I '$G(SPEED),PSONEW("DFLG")=1 S VALMSG="Renewal Request Cancelled!" W:$G(SPEED) !,"Renewal Request Cancelled!" Q:$G(PSONEW("DFLG"))
"RTN","PSOORNE4",60,0)
 .I +$G(PSONEW("ENT"))'>0 K DIRUT Q
"RTN","PSOORNE4",61,0)
 .D INS^PSODIR(.PSONEW),EN^PSOFSIG(.PSONEW),SINS^PSODIR(.PSONEW):$G(^PS(55,PSODFN,"LAN"))
"RTN","PSOORNE4",62,0)
 .S:'$G(SPEED)&(PSONEW("DFLG")=1) VALMSG="Renewal Request Cancelled!" W:$G(SPEED)&(PSONEW("DFLG")=1) !,"Renewal Request Cancelled!"
"RTN","PSOORNE4",63,0)
 .I $G(SPEED),'$G(PSONEW("DFLG")) D KV^PSOVER1 S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR,KV^PSOVER1 K X,Y
"RTN","PSOORNE4",64,0)
 I +$G(PSONEW("ENT"))'>0 G VER
"RTN","PSOORNE4",65,0)
 D STOP^PSORENW1 I +$G(PSEXDT) D  S PSORENW("QFLG")=1
"RTN","PSOORNE4",66,0)
 .S Y=PSORENW("FILL DATE") X ^DD("DD") S VALMSG=Y_" fill date is past expiration date "
"RTN","PSOORNE4",67,0)
 .S Y=$P(PSEXDT,"^",2) X ^DD("DD") S VALMSG=VALMSG_Y_"."
"RTN","PSOORNE4",68,0)
 Q
"RTN","PSOORNE4",69,0)
DSPL G:$G(PSONEW("ENT"))>0 DSP
"RTN","PSOORNE4",70,0)
 S PSONEW("ENT")=0 F I=0:0 S I=$O(^PSRX(PSONEW("OIRXN"),6,I)) Q:'I  S DOSE=^PSRX(PSONEW("OIRXN"),6,I,0) D
"RTN","PSOORNE4",71,0)
 .S PSONEW("ENT")=PSONEW("ENT")+1,PSONEW("DOSE",PSONEW("ENT"))=$P(DOSE,"^")
"RTN","PSOORNE4",72,0)
 .S PSONEW("UNITS",PSONEW("ENT"))=$P(DOSE,"^",3),PSONEW("DOSE ORDERED",PSONEW("ENT"))=$P(DOSE,"^",2),PSONEW("ROUTE",PSONEW("ENT"))=$P(DOSE,"^",7)
"RTN","PSOORNE4",73,0)
 .S PSONEW("SCHEDULE",PSONEW("ENT"))=$P(DOSE,"^",8),PSONEW("DURATION",PSONEW("ENT"))=$P(DOSE,"^",5),PSONEW("CONJUNCTION",PSONEW("ENT"))=$P(DOSE,"^",6)
"RTN","PSOORNE4",74,0)
 .S PSONEW("NOUN",PSONEW("ENT"))=$P(DOSE,"^",4),PSONEW("VERB",PSONEW("ENT"))=$P(DOSE,"^",9)
"RTN","PSOORNE4",75,0)
 .I $G(^PSRX(PSONEW("OIRXN"),6,I,1))]"" S PSONEW("ODOSE",PSONEW("ENT"))=^PSRX(PSONEW("OIRXN"),6,I,1)
"RTN","PSOORNE4",76,0)
 .K DOSE
"RTN","PSOORNE4",77,0)
DSP D ^PSOORUT2 K ^TMP("PSOPO",$J) S IEN=0
"RTN","PSOORNE4",78,0)
 D:$G(PSONEW("PENDING ORDER")) LMDISP^PSOORFI5(+PSONEW("PENDING ORDER"))
"RTN","PSOORNE4",79,0)
 I $G(PKI1)!($G(PKI)=1) D L1^PSOPKIV1 K:$G(PKI)=1 PKI
"RTN","PSOORNE4",80,0)
 D DIN^PSONFI(PSODRUG("OI"),$S($G(PSODRUG("IEN")):PSODRUG("IEN"),1:""))
"RTN","PSOORNE4",81,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="                 Rx#: "_PSONEW("NRX #")
"RTN","PSOORNE4",82,0)
 I +$G(PSODRUG("OI")) D
"RTN","PSOORNE4",83,0)
 .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="      Orderable Item: "_$P(^PS(50.7,+$G(PSODRUG("OI")),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")_NFIO
"RTN","PSOORNE4",84,0)
 .S:NFIO["<DIN>" NFIO=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4)
"RTN","PSOORNE4",85,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="     "_$S($D(^PSDRUG("AQ",PSODRUG("IEN"))):"      CMOP ",1:"           ")_"Drug: "_PSODRUG("NAME")_NFID
"RTN","PSOORNE4",86,0)
 S:NFID["<DIN>" NFID=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4)
"RTN","PSOORNE4",87,0)
 S:$G(PSONEW("TN"))]"" IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="          Trade Name: "_$G(PSONEW("TN"))
"RTN","PSOORNE4",88,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="      Patient Status: "_$P(PSONEW("PTST NODE"),"^"),PSONEW("PATIENT STATUS")=$P(PSONEW("PTST NODE"),"^")
"RTN","PSOORNE4",89,0)
 S (PSOID,Y)=PSONEW("ISSUE DATE") X ^DD("DD") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (1)     Issue Date: "_Y
"RTN","PSOORNE4",90,0)
 S Y=PSONEW("FILL DATE") X ^DD("DD") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (2)      Fill Date: "_Y
"RTN","PSOORNE4",91,0)
 I PSONEW("ENT")=0 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=$S($G(PSOREEDT):"  (9)",1:"     ")_"         Dosage:" G PAT
"RTN","PSOORNE4",92,0)
 F I=1:1:PSONEW("ENT") D
"RTN","PSOORNE4",93,0)
 .I '$G(PSONEW("DOSE ORDERED",I)),$G(PSONEW("VERB",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="                Verb: "_$G(PSONEW("VERB",I))
"RTN","PSOORNE4",94,0)
 .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=$S($G(PSOREEDT)&(I'>1):"  (9)",1:"     ")_"         Dosage: "_$S($E(PSONEW("DOSE",I),1)="."&($G(PSONEW("DOSE ORDERED",I))):"0",1:"")_PSONEW("DOSE",I)
"RTN","PSOORNE4",95,0)
 .S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_$S($G(PSONEW("UNITS",I))]"":" ("_$P(^PS(50.607,PSONEW("UNITS",I),0),"^")_")",1:"")
"RTN","PSOORNE4",96,0)
 .I $P($G(^PS(55,PSODFN,"LAN")),"^"),'$G(PSONEW("DOSE ORDERED",I)) D
"RTN","PSOORNE4",97,0)
 ..S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="   Oth. Lang. Dosage: "_$G(PSONEW("ODOSE",I))
"RTN","PSOORNE4",98,0)
 .I $G(PSONEW("DOSE ORDERED",I)),$G(PSONEW("VERB",I))]"" D
"RTN","PSOORNE4",99,0)
 ..S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="                Verb: "_$G(PSONEW("VERB",I))
"RTN","PSOORNE4",100,0)
 ..S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="      Dispense Units: "_$S($E($G(PSONEW("DOSE ORDERED",I)),1)=".":"0",1:"")_$G(PSONEW("DOSE ORDERED",I))
"RTN","PSOORNE4",101,0)
 ..S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="                Noun: "_$G(PSONEW("NOUN",I))
"RTN","PSOORNE4",102,0)
 .I $G(PSONEW("ROUTE",I)) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="               Route: "_$P(^PS(51.2,PSONEW("ROUTE",I),0),"^")
"RTN","PSOORNE4",103,0)
 .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="            Schedule: "_PSONEW("SCHEDULE",I)
"RTN","PSOORNE4",104,0)
 .I $G(PSONEW("DURATION",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="           *Duration: "_$G(PSONEW("DURATION",I))
"RTN","PSOORNE4",105,0)
 .I $G(PSONEW("CONJUNCTION",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="         Conjunction: "_$S($G(PSONEW("CONJUNCTION",I))="A":"AND",$G(PSONEW("CONJUNCTION",I))="T":"THEN",$G(PSONEW("CONJUNCTION",I))="X":"EXCEPT",1:"")
"RTN","PSOORNE4",106,0)
PAT S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=$S($G(PSOREEDT):" (10)",1:"     ")_"Pat Instruction:" D INS2^PSOBKDED
"RTN","PSOORNE4",107,0)
 S RXN=PSONEW("OIRXN") D INST1^PSORENW
"RTN","PSOORNE4",108,0)
 ;I $O(PRC(0)) D PC1^PSOORNE5
"RTN","PSOORNE4",109,0)
 K RXN S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="                 SIG:"
"RTN","PSOORNE4",110,0)
 I $G(SIGOK),$O(SIG(0)) D  K SG,MIG
"RTN","PSOORNE4",111,0)
 .F I=0:0 S I=$O(SIG(I)) Q:'I  F SG=1:1:$L(SIG(I)) D
"RTN","PSOORNE4",112,0)
 ..S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(SIG(I)," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",21)=" "
"RTN","PSOORNE4",113,0)
 ..S:$P(SIG(I)," ",SG)'="" ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(SIG(I)," ",SG)
"RTN","PSOORNE4",114,0)
 E  D
"RTN","PSOORNE4",115,0)
 .S X=$S($G(PSONEW("SIG"))]"":PSONEW("SIG"),1:$P($G(^PSRX(PSONEW("OIRXN"),"SIG")),"^")) D SIGONE^PSOHELP S SIG=$E($G(INS1),2,250)
"RTN","PSOORNE4",116,0)
 .F SG=1:1:$L(SIG) S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(SIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",21)=" " S:$P(SIG," ",SG)'="" ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(SIG," ",SG)
"RTN","PSOORNE4",117,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="         Days Supply: "_PSONEW("DAYS SUPPLY")_$S($L(PSONEW("DAYS SUPPLY"))=1:" ",1:"")
"RTN","PSOORNE4",118,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="                 QTY"_$S($G(PSODRUG("UNIT"))]"":" ("_PSODRUG("UNIT")_")",1:" (  )")_": "_PSONEW("QTY")
"RTN","PSOORNE4",119,0)
 I $D(^PSDRUG("AQ",PSODRUG("IEN"))),$P($G(^PSDRUG(PSODRUG("IEN"),5)),"^")]"" D
"RTN","PSOORNE4",120,0)
 .S $P(RN," ",79)=" ",IEN=IEN+1
"RTN","PSOORNE4",121,0)
 .S ^TMP("PSOPO",$J,IEN,0)="            QTY DSP MSG: "_$P(^PSDRUG(PSODRUG("IEN"),5),"^")
"RTN","PSOORNE4",122,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (3)   # of Refills: "_PSONEW("# OF REFILLS")_$S($L(PSONEW("# OF REFILLS"))=1:" ",1:"")
"RTN","PSOORNE4",123,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (4)        Routing: "_$S($G(PSORENW("MAIL/WINDOW"))["W":"WINDOW",1:"MAIL")
"RTN","PSOORNE4",124,0)
 S:$G(PSONEW("METHOD OF PICK-UP"))]""&($P(PSOPAR,"^",12)) IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="    Method of Pickup: "_PSONEW("METHOD OF PICK-UP")
"RTN","PSOORNE4",125,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (5)         Clinic: "_$S($G(PSONEW("CLINIC")):$P(^SC(PSONEW("CLINIC"),0),"^"),1:"")
"RTN","PSOORNE4",126,0)
 S $P(RN," ",31)=" ",IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (6)       Provider: "_PSONEW("PROVIDER NAME")_$E(RN,$L(PSONEW("PROVIDER NAME"))+1,31) K RN
"RTN","PSOORNE4",127,0)
 I $G(PSODRUG("DEA")),+PSODRUG("DEA")>1,+PSODRUG("DEA")<6 D PRV^PSOORFI5($G(PSORENW("PROVIDER")),$G(PSODRUG("IEN")))
"RTN","PSOORNE4",128,0)
 I $G(PSONEW("COSIGNING PROVIDER"))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="        Cos-Provider: "_$P(^VA(200,PSONEW("COSIGNING PROVIDER"),0),"^")
"RTN","PSOORNE4",129,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (7)         Copies: "_$S($G(PSONEW("COPIES")):PSONEW("COPIES"),1:1)
"RTN","PSOORNE4",130,0)
RMK S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (8)        Remarks: "_$S($G(PSONEW("REMARKS"))]"":PSONEW("REMARKS"),1:"")
"RTN","PSOORNE4",131,0)
 S $P(RN," ",35)=" ",IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="   Entry By: "_$P(^VA(200,DUZ,0),"^")_$E(RN,$L($P(^VA(200,DUZ,0),"^"))+1,35)
"RTN","PSOORNE4",132,0)
 I $G(PSOFDR) S ^TMP("PSOPO",$J,IEN,0)="   Entry By: "_$P(^VA(200,$P(OR0,"^",4),0),"^")_$E(RN,$L($P(^VA(200,$P(OR0,"^",4),0),"^"))+1,35)
"RTN","PSOORNE4",133,0)
 D NOW^%DTC S PSONEW("LOGIN DATE")=$S($P($G(OR0),"^",6):$P($G(OR0),"^",6),1:%) K %,X S Y=PSONEW("LOGIN DATE") X ^DD("DD")
"RTN","PSOORNE4",134,0)
 S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"Entry Date: "_$P(Y,"@")_" "_$P(Y,"@",2) K RN
"RTN","PSOORNE4",135,0)
 S (VALMCNT,PSOPF)=IEN
"RTN","PSOORNE4",136,0)
 I $G(PSOFDR) D:$P(OR0,"^",24)
"RTN","PSOORNE4",137,0)
 .K PSOCSP S PSOCSP("NAME")=$G(PSODRUG("NAME")) M PSOCSP("DOSE")=PSONEW("DOSE"),PSOCSP("DOSE ORDERED")=PSONEW("DOSE ORDERED")
"RTN","PSOORNE4",138,0)
 .S PSOCSP("# OF REFILLS")=PSONEW("# OF REFILLS") ;track original data for dig. orders
"RTN","PSOORNE4",139,0)
 .S PSOCSP("ISSUE DATE")=$E($P(OR0,"^",6),1,7),PSOCSP("QTY")=PSONEW("QTY"),PSOCSP("DAYS SUPPLY")=PSONEW("DAYS SUPPLY")
"RTN","PSOORNE4",140,0)
 Q
"RTN","PSOORNE4",141,0)
1 D 1^PSOBKDED Q
"RTN","PSOORNE4",142,0)
2 D 2^PSOBKDED Q
"RTN","PSOORNE4",143,0)
3 I $P($G(OR0),"^",24) D  Q
"RTN","PSOORNE4",144,0)
  . W !!,"Digitally Signed Order - Refills cannot be changed",! D PZ
"RTN","PSOORNE4",145,0)
  D 9^PSOBKDED Q
"RTN","PSOORNE4",146,0)
4 D 12^PSOBKDED Q
"RTN","PSOORNE4",147,0)
5 D 5^PSOBKDED Q
"RTN","PSOORNE4",148,0)
6 I $P($G(OR0),"^",24) D  Q
"RTN","PSOORNE4",149,0)
  . W !!,"Digitally Signed Order - Provider cannot be changed",! D PZ
"RTN","PSOORNE4",150,0)
  D 4^PSOBKDED Q
"RTN","PSOORNE4",151,0)
7 D 11^PSOBKDED Q
"RTN","PSOORNE4",152,0)
8 D 13^PSOBKDED Q
"RTN","PSOORNE4",153,0)
9 W !!,"Drug: "_PSODRUG("NAME") S PSOORRNW=1 D DOSE1^PSOORED5(.PSONEW)
"RTN","PSOORNE4",154,0)
 I $G(PSONEW("DFLG")) S PSODIR("DFLG")=1,VALMBCK="Q" Q
"RTN","PSOORNE4",155,0)
 D SV Q
"RTN","PSOORNE4",156,0)
10 D INS^PSODIR(.PSONEW),SINS^PSODIR(.PSONEW) D SV Q
"RTN","PSOORNE4",157,0)
SV D SV^PSOORNE5 Q
"RTN","PSOORNE4",158,0)
 ;
"RTN","PSOORNE4",159,0)
PZ ;
"RTN","PSOORNE4",160,0)
 N DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR W !
"RTN","PSOORNE4",161,0)
 Q
"RTN","PSOORNE5")
0^17^B68801944^B60780567
"RTN","PSOORNE5",1,0)
PSOORNE5 ;BIR/SAB - display orders from backdoor con't ;5/10/07 8:29am
"RTN","PSOORNE5",2,0)
 ;;7.0;OUTPATIENT PHARMACY;**11,27,32,46,78,99,117,131,146,171,180,210,222,268,206,225,391**;DEC 1997;Build 13
"RTN","PSOORNE5",3,0)
 ;External reference to ^PSDRUG supported by DBIA 221
"RTN","PSOORNE5",4,0)
 ;External references L and UL^PSSLOCK supported by DBIA 2789
"RTN","PSOORNE5",5,0)
 ;External reference to ^PS(51.2 supported by DBIA 2226
"RTN","PSOORNE5",6,0)
 ;External reference to ^PS(50.607 supported by DBIA 2221
"RTN","PSOORNE5",7,0)
 ;External reference ^PS(55 supported by DBIA 2228
"RTN","PSOORNE5",8,0)
 ;called from PSOORNE2
"RTN","PSOORNE5",9,0)
 ;PSO*210 add call to WORDWRAP api
"RTN","PSOORNE5",10,0)
 ;
"RTN","PSOORNE5",11,0)
PEN ;pending orders
"RTN","PSOORNE5",12,0)
 K ^TMP("PSOPO",$J),PSORX("ISSUE DATE"),PSORX("FILL DATE") S ORSV=ORD,ORD=$P(PSOLST(ORN),"^",2)
"RTN","PSOORNE5",13,0)
 I $P($G(^PS(52.41,ORD,0)),"^",3)="DC"!($P($G(^(0)),"^",3)="DE") S VALMBCK="R" Q
"RTN","PSOORNE5",14,0)
 I $G(PSODFN)'=$P($G(^PS(52.41,ORD,0)),"^",2) S VALMBCK="" Q
"RTN","PSOORNE5",15,0)
 I $G(PSOTPBFG) N PSOTPPEN,PSOTPPEX S PSOTPPEN=ORD,PSOTPPEX=0 D VOPNR^PSOTPCAN I PSOTPPEX K PSOTPPEX,PSOTPPEN S VALMBCK="R" Q
"RTN","PSOORNE5",16,0)
 K PSOTPPEX,PSOTPPEN
"RTN","PSOORNE5",17,0)
 ;I '$G(PSOTPBFG) D DSPL^PSOTPCAN(ORD)
"RTN","PSOORNE5",18,0)
 ;S X=PSODFN_";DPT(" D LK^ORX2 I 'Y S VALMSG="Another person is entering orders for this patient.",VALMBCK="" Q
"RTN","PSOORNE5",19,0)
 I '$G(PSOFIN) S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient."),VALMBCK="" K PSOPLCK Q
"RTN","PSOORNE5",20,0)
 K PSOPLCK ; D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)_"S") I '$G(PSOMSG) S VAMLSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),PSOACT="" K PSOMSG G OK ;VALMBCK="" Q
"RTN","PSOORNE5",21,0)
 S PSODRG=+$P($G(^PS(52.41,ORD,0)),"^",9) I $G(^PSDRUG(PSODRG,"I"))]"",DT>$G(^("I")) S VALMSG="This Drug has been Inactivated."
"RTN","PSOORNE5",22,0)
 I $P($G(^PS(52.41,ORD,0)),"^",24) S PSOACT=$S($D(^XUSEC("PSDRPH",DUZ)):"DEFX",$D(^XUSEC("PSORPH",DUZ)):"F",$P($G(PSOPAR),"^",2):"F",1:"")
"RTN","PSOORNE5",23,0)
 E  S PSOACT=$S($D(^XUSEC("PSORPH",DUZ)):"DEFX",'$D(^XUSEC("PSORPH",DUZ))&($P($G(PSOPAR),"^",2)):"F",1:"")
"RTN","PSOORNE5",24,0)
 K PSOMSG
"RTN","PSOORNE5",25,0)
OK S PAT=PSODFN,PSORNSV=ORN,PSORNLT=PSLST D ORD^PSOORFIN S PSLST=PSORNLT,ORD=ORSV,ORN=PSORNSV K ORSV,PSORNSV,PSORNLT,PSODRUG S VALMBCK="R"
"RTN","PSOORNE5",26,0)
 K ORCHK,ORDRG,PSOFDR,SIGOK,PSONEW,PSORX("ISSUE DATE"),PSORX("FILL DATE"),PSORX("FN")
"RTN","PSOORNE5",27,0)
 K:'$G(MEDP) PAT
"RTN","PSOORNE5",28,0)
 D CLEAN^PSOVER1 ;S X=PSODFN_";DPT(" D ULK^ORX2
"RTN","PSOORNE5",29,0)
 I '$G(PSOFIN) D UL^PSSLOCK(PSODFN)
"RTN","PSOORNE5",30,0)
 Q
"RTN","PSOORNE5",31,0)
RXNCHK S PSOY=$O(PSONEW("OLD LAST RX#","")) I PSOY="" D AUTO^PSONRXN Q
"RTN","PSOORNE5",32,0)
 S PSONRXN("TYPE")=$S('+$G(^PS(59,+PSOSITE,2)):8,PSODRUG("DEA")["A"&(+$G(^PS(59,+PSOSITE,2))):3,1:8)
"RTN","PSOORNE5",33,0)
 S PSONEW("QFLG")=0 I PSOY'=PSONRXN("TYPE"),$P($G(PSOPAR),"^",7)=1 D
"RTN","PSOORNE5",34,0)
 .S DIE="^PS(59,",DA=PSOSITE,PSOX=PSONEW("OLD LAST RX#",PSOY)
"RTN","PSOORNE5",35,0)
 .L +^PS(59,+PSOSITE,PSOY):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
"RTN","PSOORNE5",36,0)
 .S DR=$S(PSOY=8:"2003////"_PSOX,PSOY=3:"1002.1////"_PSOX,1:"2003////"_PSOX)
"RTN","PSOORNE5",37,0)
 .D:PSOX<$P(^PS(59,+PSOSITE,PSOY),"^",3) ^DIE K DIE,X,Y L -^PS(59,+PSOSITE,PSOY)
"RTN","PSOORNE5",38,0)
 .L +^PS(59,+PSOSITE,PSONRXN("TYPE")):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
"RTN","PSOORNE5",39,0)
 .S PSOX1=^PS(59,+PSOSITE,PSONRXN("TYPE")),PSONRXN("LO")=$P(PSOX1,"^")
"RTN","PSOORNE5",40,0)
 .S PSONRXN("HI")=$P(PSOX1,"^",2),PSOI=$P(PSOX1,"^",3),PSONEW("OLD LAST RX#",PSONRXN("TYPE"))=PSOI
"RTN","PSOORNE5",41,0)
 .S:PSOI<PSONRXN("LO") PSOI=PSONRXN("LO")
"RTN","PSOORNE5",42,0)
 .D LOOP2 I PSONEW("QFLG") L -^PS(59,+PSOSITE,PSONRXN("TYPE")),-^PSRX("B",PSOI) Q
"RTN","PSOORNE5",43,0)
 .K DIC,DIE,DA S DIE=59,DA=PSOSITE
"RTN","PSOORNE5",44,0)
 .S DR=$S(PSONRXN("TYPE")=8:"2003////"_PSOI,PSONRXN("TYPE")=3:"1002.1////"_PSOI,1:"2003////"_PSOI)
"RTN","PSOORNE5",45,0)
 .S PSONEW("RX #")=PSOI D ^DIE K DIE,DIC,DR,DA L -^PS(59,+PSOSITE,PSONRXN("TYPE"))
"RTN","PSOORNE5",46,0)
 .K PSOX1,PSONRXN,PSOI,X,Y
"RTN","PSOORNE5",47,0)
 Q
"RTN","PSOORNE5",48,0)
LOOP2 F  S PSOI=PSOI+1 D:PSOI>PSONRXN("HI") FATAL^PSONRXN Q:'$D(^PSRX("B",PSOI))!PSONEW("QFLG")
"RTN","PSOORNE5",49,0)
 L +^PSRX("B",PSOI):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I $D(^PSRX("B",PSOI))!'$T G LOOP2
"RTN","PSOORNE5",50,0)
 L -^PSRX("B",PSOI)
"RTN","PSOORNE5",51,0)
 Q
"RTN","PSOORNE5",52,0)
RDSPL S PSODIR("CS")=0
"RTN","PSOORNE5",53,0)
 F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSODIR("CS"),"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSODIR("CS"),"^",2)=1
"RTN","PSOORNE5",54,0)
 I $P($G(PSODIR("CS")),"^",2)=1 S (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=0 Q
"RTN","PSOORNE5",55,0)
 I '$D(CLOZPAT) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F")!(PSODRUG("DEA")[1)!(PSODRUG("DEA")[2) S (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=0 Q
"RTN","PSOORNE5",56,0)
 I $D(CLOZPAT) S (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=$S($G(CLOZPAT)=2&(PSONEW("DAYS SUPPLY")=14):1,$G(CLOZPAT)=2&(PSONEW("DAYS SUPPLY")=7):3,$G(CLOZPAT)=1&(PSONEW("DAYS SUPPLY")=7):1,1:0) Q
"RTN","PSOORNE5",57,0)
 I PSODIR("CS") D
"RTN","PSOORNE5",58,0)
 .S PSOX=5,PSOX1=$S($P($G(PSONEW("PTST NODE")),"^",4)>PSOX:PSOX,1:$P($G(PSONEW("PTST NODE")),"^",4)),PSOX=$S(PSOX1=5:PSOX,1:PSOX1)
"RTN","PSOORNE5",59,0)
 .S PSOX=$S('PSOX:0,PSONEW("DAYS SUPPLY")=90:1,1:PSOX),PSDY=PSONEW("DAYS SUPPLY"),PSDY1=$S(PSDY<60:5,PSDY'<60&(PSDY'>89):2,PSDY=90:1,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
"RTN","PSOORNE5",60,0)
 .I PSONEW("# OF REFILLS")>PSOX S (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=PSOX
"RTN","PSOORNE5",61,0)
 E  D
"RTN","PSOORNE5",62,0)
 .S PSOX=11,PSOX1=$S($P($G(PSONEW("PTST NODE")),"^",4)>PSOX:PSOX,1:$P($G(PSONEW("PTST NODE")),"^",4)),PSOX=$S(PSOX1=11:PSOX,1:PSOX1)
"RTN","PSOORNE5",63,0)
 .S PSDY=PSONEW("DAYS SUPPLY"),PSDY1=$S(PSDY<60:11,PSDY'<60&(PSDY'>89):5,PSDY=90:3,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
"RTN","PSOORNE5",64,0)
 .I PSONEW("# OF REFILLS")>PSOX S (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=PSOX
"RTN","PSOORNE5",65,0)
 Q
"RTN","PSOORNE5",66,0)
GET ;
"RTN","PSOORNE5",67,0)
 I $P(PSODRUG0,"^",3)["2" S (ACTREF,ACTREN)=0 Q
"RTN","PSOORNE5",68,0)
 S (ACTREF,ACTREN)=1
"RTN","PSOORNE5",69,0)
 ;refills
"RTN","PSOORNE5",70,0)
 I ST S ACTREF=0
"RTN","PSOORNE5",71,0)
 I '$P(PSOPAR,"^",11),$G(^PSDRUG(PSODRG,"I"))]"",DT>$G(^("I")) S ACTREF=0,VALMSG="Inactive Drug, Non Refillable!"
"RTN","PSOORNE5",72,0)
 ;I $P($G(^PSDRUG(PSODRG,2)),"^",3)'["O" S ACTREF=0
"RTN","PSOORNE5",73,0)
 S PSORFRM=$P(RX0,"^",9) F PSOJ=0:0 S PSOJ=$O(^PSRX(RXN,1,PSOJ)) Q:'PSOJ  S PSORFRM=PSORFRM-1
"RTN","PSOORNE5",74,0)
 S:PSORFRM<0 PSORFRM=0 S:PSORFRM=0 ACTREF=0
"RTN","PSOORNE5",75,0)
 I $G(RXFL(RXN))]"",'$P(PSOPAR,"^",6) S ACTREF=0
"RTN","PSOORNE5",76,0)
 I $P(PSODRUG0,"^",3)["A"&($P(PSODRUG0,"^",3)'["B")!($P(PSODRUG0,"^",3)["F")!($P(PSODRUG0,"^",3)[1)!($P(PSODRUG0,"^",3)[2) S ACTREF=0
"RTN","PSOORNE5",77,0)
 ;renews
"RTN","PSOORNE5",78,0)
 I $P(PSOPAR,"^",4)=0 S ACTREN=0 Q
"RTN","PSOORNE5",79,0)
 I $P($G(^PSDRUG(PSODRG,2)),"^",3)'["O" S ACTREN=0
"RTN","PSOORNE5",80,0)
 I $G(^PSDRUG(PSODRG,"I"))]"",DT>$G(^("I")) S ACTREN=0,VALMSG="This Drug has been Inactivated."
"RTN","PSOORNE5",81,0)
 I '$P($G(^PSDRUG(PSODRG,2)),"^"),'$P($G(^PSRX(RXN,"OR1")),"^") S ACTREN=0,VALMSG="Drug must be Matched to an Orderable Item!"
"RTN","PSOORNE5",82,0)
 I ($P(PSODRUG0,"^",3)["W")!($P(PSODRUG0,"^",3)[1)!($P(PSODRUG0,"^",3)[2) S ACTREN=0
"RTN","PSOORNE5",83,0)
 I $D(^PS(53,+$P(RX0,"^",3),0)),'$P(^(0),"^",5) S ACTREN=0
"RTN","PSOORNE5",84,0)
 S PSOLC=$P(RX0,"^"),PSOLC=$E(PSOLC,$L(PSOLC)) I $A(PSOLC)'<90 S ACTREN=0
"RTN","PSOORNE5",85,0)
 I ST,ST'=2,ST'=5,ST'=6,ST'=11,ST'=12 S ACTREN=0
"RTN","PSOORNE5",86,0)
 K PSORFRM,PSOLC,PSODRG,PSODRUG0
"RTN","PSOORNE5",87,0)
 Q
"RTN","PSOORNE5",88,0)
INST ;formats instruction from front door
"RTN","PSOORNE5",89,0)
 D INST^PSOORNE6 Q
"RTN","PSOORNE5",90,0)
PC ;displays provider comments
"RTN","PSOORNE5",91,0)
 D PC^PSOORNE6 Q
"RTN","PSOORNE5",92,0)
INST1 ;formats instruction from front door
"RTN","PSOORNE5",93,0)
 D INST1^PSOORNE6 Q
"RTN","PSOORNE5",94,0)
PC1 ;displays provider comments
"RTN","PSOORNE5",95,0)
 D PC1^PSOORNE6 Q
"RTN","PSOORNE5",96,0)
DOSE ;displays dosing instruction for both simple and complex backdoor Rxs.
"RTN","PSOORNE5",97,0)
 I '$O(^PSRX(RXN,6,0))  S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" (3)          Dosage: " Q
"RTN","PSOORNE5",98,0)
 S DS=1 F I=0:0 S I=$O(^PSRX(RXN,6,I)) Q:'I  S DOSE=^PSRX(RXN,6,I,0) D
"RTN","PSOORNE5",99,0)
 .I '$P(DOSE,"^",2),$P(DOSE,"^",9)]"" S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="                Verb: "_$P(DOSE,"^",9)
"RTN","PSOORNE5",100,0)
 .I $G(DS)=1 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" (3)"
"RTN","PSOORNE5",101,0)
 .D DOSE1 S PSORXED("ENT")=$G(PSORXED("ENT"))+1
"RTN","PSOORNE5",102,0)
 K DOSE,I
"RTN","PSOORNE5",103,0)
 Q
"RTN","PSOORNE5",104,0)
DOSE1 ;
"RTN","PSOORNE5",105,0)
 I $G(DS)=1 S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_"         *Dosage: "_$S($E($P(DOSE,"^"),1)="."&($P(DOSE,"^",2)):"0",1:"")_$P(DOSE,"^")_$S($P(DOSE,"^",3)]"":" ("_$P(^PS(50.607,$P(DOSE,"^",3),0),"^")_")",1:"") K DS G DU
"RTN","PSOORNE5",106,0)
 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="             *Dosage: "_$S($E($P(DOSE,"^"),1)="."&($P(DOSE,"^",2)):"0",1:"")_$P(DOSE,"^")_$S($P(DOSE,"^",3)]"":" ("_$P(^PS(50.607,$P(DOSE,"^",3),0),"^")_")",1:"")
"RTN","PSOORNE5",107,0)
DU I '$P(DOSE,"^",2),$P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="   Oth. Lang. Dosage: "_$G(^PSRX(RXN,6,I,1))
"RTN","PSOORNE5",108,0)
 I $P(DOSE,"^",2),$P(DOSE,"^",9)]"" D
"RTN","PSOORNE5",109,0)
 .S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="                Verb: "_$P(DOSE,"^",9)
"RTN","PSOORNE5",110,0)
 .S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="      Dispense Units: "_$S($E($P(DOSE,"^",2),1)=".":"0",1:"")_$P(DOSE,"^",2)
"RTN","PSOORNE5",111,0)
 .S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="                Noun: "_$P(DOSE,"^",4)
"RTN","PSOORNE5",112,0)
 I $P(DOSE,"^",7) S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="              *Route: "_$P(^PS(51.2,$P(DOSE,"^",7),0),"^")
"RTN","PSOORNE5",113,0)
 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="           *Schedule: "_$P(DOSE,"^",8)
"RTN","PSOORNE5",114,0)
 I $P(DOSE,"^",5)]"" D
"RTN","PSOORNE5",115,0)
 .S DUR=$S($E($P(DOSE,"^",5),1)'?.N:$E($P(DOSE,"^",5),2,99)_$E($P(DOSE,"^",5),1),1:$P(DOSE,"^",5))
"RTN","PSOORNE5",116,0)
 .S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="           *Duration: "_DUR_" ("_$S($P(DOSE,"^",5)["M":"MINUTES",$P(DOSE,"^",5)["H":"HOURS",$P(DOSE,"^",5)["L":"MONTHS",$P(DOSE,"^",5)["W":"WEEKS",1:"DAYS")_")" K DUR
"RTN","PSOORNE5",117,0)
 I $P(DOSE,"^",6)]"" S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="        *Conjunction: "_$S($P(DOSE,"^",6)="A":"AND",$P(DOSE,"^",6)="T":"THEN",$P(DOSE,"^",6)="X":"EXCEPT",1:"")
"RTN","PSOORNE5",118,0)
 Q
"RTN","PSOORNE5",119,0)
INS ;patient instructions                                        ;PSO*210
"RTN","PSOORNE5",120,0)
 I $G(^PSRX(RXN,"INS"))]"",'$O(^PSRX(RXN,"INS1",0)) D  K SG G SPINS
"RTN","PSOORNE5",121,0)
 .S PSORXED("SIG",1)=^PSRX(RXN,"INS")
"RTN","PSOORNE5",122,0)
 .D WORDWRAP^PSOUTLA2(^PSRX(RXN,"INS"),.IEN,$NA(^TMP("PSOAO",$J)),21)
"RTN","PSOORNE5",123,0)
 ;
"RTN","PSOORNE5",124,0)
 I $O(^PSRX(RXN,"INS1",0)) D
"RTN","PSOORNE5",125,0)
 .S T=0 F  S T=$O(^PSRX(RXN,"INS1",T)) Q:'T  D
"RTN","PSOORNE5",126,0)
 .. S (PSORXED("SIG",T),MIG)=^PSRX(RXN,"INS1",T,0)
"RTN","PSOORNE5",127,0)
 .. D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOAO",$J)),21)
"RTN","PSOORNE5",128,0)
SPINS K T,SG,MIG
"RTN","PSOORNE5",129,0)
 I $P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="  Other Pat. Instruc: "_$S($G(^PSRX(RXN,"INSS"))]"":^PSRX(RXN,"INSS"),1:"")
"RTN","PSOORNE5",130,0)
 Q
"RTN","PSOORNE5",131,0)
SV S VALMSG="Pre-POE Rx. Please Compare Dosing Fields with SIG!"
"RTN","PSOORNE5",132,0)
 Q
"RTN","PSOORNE5",133,0)
PRV ;
"RTN","PSOORNE5",134,0)
 N DETN,DEA,I,LBL,VADD,SPC,ORN S ORN=ORD
"RTN","PSOORNE5",135,0)
 S DEA=$$DEA^XUSER(0,$P(RX0,"^",4))
"RTN","PSOORNE5",136,0)
 S LBL=$S(DEA["-":"  VA#: ",1:" DEA#: ")
"RTN","PSOORNE5",137,0)
 I $$DETOX^PSSOPKI($P(RX0,"^",6)) S DETN=$$DETOX^XUSER($P(RX0,"^",4))
"RTN","PSOORNE5",138,0)
 S $P(SPC," ",(28-$L(DEA)))=" "
"RTN","PSOORNE5",139,0)
 I (DEA'="")!($G(DETN)'="") S IEN=IEN+1,$E(^TMP("PSOAO",$J,IEN,0),16)=LBL_DEA_$S($G(DETN)]"":SPC_"DETOX#: "_$G(DETN),1:"")
"RTN","PSOORNE5",140,0)
 D PRVAD^PSOPKIV2
"RTN","PSOORNE5",141,0)
 I $G(VADD(1))]"" D
"RTN","PSOORNE5",142,0)
 .S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="        Site Address: "_VADD(1)
"RTN","PSOORNE5",143,0)
 .S:VADD(2)'="" IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="                      "_VADD(2) S:VADD(3)'="" IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="                      "_VADD(3)
"RTN","PSOORNE5",144,0)
 Q
"RTN","PSOORNEW")
0^15^B92744719^B81591143
"RTN","PSOORNEW",1,0)
PSOORNEW ;BIR/SAB - display orders from oerr ;6/19/06 3:53pm
"RTN","PSOORNEW",2,0)
 ;;7.0;OUTPATIENT PHARMACY;**11,23,27,32,55,46,71,90,94,106,131,133,143,237,222,258,206,225,251,386,390,391**;DEC 1997;Build 13
"RTN","PSOORNEW",3,0)
 ;^PS(50.7 -2223
"RTN","PSOORNEW",4,0)
 ;^PSDRUG -221
"RTN","PSOORNEW",5,0)
 ;^PS(50.606 -2174
"RTN","PSOORNEW",6,0)
 ;^PS(55 -2228
"RTN","PSOORNEW",7,0)
 ;EN1^ORCFLAG -3620
"RTN","PSOORNEW",8,0)
 ;External reference to $$DS^PSSDSAPI supported by DBIA 5424
"RTN","PSOORNEW",9,0)
 ;
"RTN","PSOORNEW",10,0)
 ;PSO*237 quit Finish if Today > Issue date + 365
"RTN","PSOORNEW",11,0)
 ;
"RTN","PSOORNEW",12,0)
DSPL I $G(PSODSPL) S VALMBCK="Q" K PSODSPL,PSOANSQD Q
"RTN","PSOORNEW",13,0)
 Q:'$D(PSOLMC)  K ^TMP("PSOPO",$J) S PSOLMC=PSOLMC+1
"RTN","PSOORNEW",14,0)
 I $D(CLOZPAT) S PSONEW("DAYS SUPPLY")=$S($G(PSONEW("DAYS SUPPLY")):PSONEW("DAYS SUPPLY"),1:7) G OI
"RTN","PSOORNEW",15,0)
 S PSONEW("DAYS SUPPLY")=$S($G(PSONEW("DAYS SUPPLY")):PSONEW("DAYS SUPPLY"),+$G(^PS(55,PSODFN,"PS"))&($P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",3))&('$G(PSONEW("DAYS SUPPLY"))):$P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",3),1:30)
"RTN","PSOORNEW",16,0)
OI I '$G(PSODRUG("OI")) D
"RTN","PSOORNEW",17,0)
 .S (OI,PSODRUG("OI"))=$P(OR0,"^",8),PSODRUG("OIN")=$P(^PS(50.7,$P(OR0,"^",8),0),"^"),OID=$P(OR0,"^",9)
"RTN","PSOORNEW",18,0)
 .I $P($G(OR0),"^",9) S POERR=1,DREN=$P(OR0,"^",9) D DRG^PSOORDRG K POERR
"RTN","PSOORNEW",19,0)
 I '$D(CLOZPAT) I $G(PSODRUG("DEA"))["A",$G(PSODRUG("DEA"))'["B"!($G(PSODRUG("DEA"))["F") S PSONEW("# OF REFILLS")=0
"RTN","PSOORNEW",20,0)
 I $D(CLOZPAT) S PSONEW("# OF REFILLS")=$S($D(PSONEW("# OF REFILLS")):PSONEW("# OF REFILLS"),$G(CLOZPAT)=2&($P(OR0,"^",11)>2):3,$G(CLOZPAT)&($P(OR0,"^",11)>1):1,1:0)
"RTN","PSOORNEW",21,0)
 S IEN=0 D OBX^PSOORFI1,DIN^PSONFI(PSODRUG("OI"),$S($G(PSODRUG("IEN")):PSODRUG("IEN"),1:""))
"RTN","PSOORNEW",22,0)
 D LMDISP^PSOORFI5(+$G(ORD)) ; Display Flag/Unflag Information
"RTN","PSOORNEW",23,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="*(1) Orderable Item: "_$P(^PS(50.7,PSODRUG("OI"),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")_NFIO
"RTN","PSOORNEW",24,0)
 S:NFIO["<DIN>" NFIO=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4)
"RTN","PSOORNEW",25,0)
 K LST I $G(PSODRUG("NAME"))]"" D  G PT
"RTN","PSOORNEW",26,0)
 .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (2)"_$S($D(^PSDRUG("AQ",PSODRUG("IEN"))):"      CMOP ",1:"           ")_"Drug: "_PSODRUG("NAME")_NFID
"RTN","PSOORNEW",27,0)
 .S:NFID["<DIN>" NFID=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4)
"RTN","PSOORNEW",28,0)
 .I $P($G(^PSDRUG(PSODRUG("IEN"),0)),"^",10)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="       Drug Message:" D DRGMSG
"RTN","PSOORNEW",29,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (2)           Drug: No Dispense Drug Selected"
"RTN","PSOORNEW",30,0)
PT D DOSE2^PSOORFI4
"RTN","PSOORNEW",31,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (4)   Pat Instruct:" D:$O(PSONEW("SIG",0)) INST^PSOORFI4
"RTN","PSOORNEW",32,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  Provider Comments:" S TY=3 D INST^PSOORFI1
"RTN","PSOORNEW",33,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="       Instructions:" S TY=2 D INST^PSOORFI1
"RTN","PSOORNEW",34,0)
 K PSOELSE S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="                SIG:"
"RTN","PSOORNEW",35,0)
 F I=0:0 S I=$O(SIG(I)) Q:'I  S SIG=SIG(I) D
"RTN","PSOORNEW",36,0)
 .F SG=1:1:$L(SIG) S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(SIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " S:$P(SIG," ",SG)'="" ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(SIG," ",SG)
"RTN","PSOORNEW",37,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (5) Patient Status: "_$P($G(^PS(53,+PSONEW("PATIENT STATUS"),0)),"^")
"RTN","PSOORNEW",38,0)
 K PSOELSE I $G(PSONEW("ISSUE DATE"))']"" S PSOELSE=1 S IEN=IEN+1,(PSOID,Y)=$E($P(OR0,"^",6),1,7) X ^DD("DD") S PSONEW("ISSUE DATE")=Y,^TMP("PSOPO",$J,IEN,0)=" (4)     Issue Date: "_Y
"RTN","PSOORNEW",39,0)
 I '$G(PSOELSE) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (6)     Issue Date: "_PSONEW("ISSUE DATE")
"RTN","PSOORNEW",40,0)
 K PSOELSE I $G(PSORX("FILL DATE"))']"" S PSOELSE=1 D
"RTN","PSOORNEW",41,0)
 .S (Y,PSORX("FILL DATE"))=$S($E($P(OR0,"^",6),1,7)<DT:DT,1:$E($P(OR0,"^",6),1,7)) X ^DD("DD") S PSONEW("FILL DATE")=Y,^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"                  (5) Fill Date: "_Y
"RTN","PSOORNEW",42,0)
 I '$G(PSOELSE) S Y=PSORX("FILL DATE") X ^DD("DD") S PSORX("FILL DATE")=Y,^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"       (7) Fill Date: "_PSORX("FILL DATE")
"RTN","PSOORNEW",43,0)
 I $P(OR0,"^",18) S IEN=IEN+1,Y=$P(OR0,"^",18) X ^DD("DD") S $P(^TMP("PSOPO",$J,IEN,0)," ",39)="Effective Date: "_Y
"RTN","PSOORNEW",44,0)
 I $D(CLOZPAT) D ELIG^PSOORFI2 S:'$D(PSONEW("QTY")) PSONEW("QTY")=0
"RTN","PSOORNEW",45,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (8)    Days Supply: "_PSONEW("DAYS SUPPLY")
"RTN","PSOORNEW",46,0)
 S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"               (9)   QTY"_$S($P($G(^PSDRUG(+$G(PSODRUG("IEN")),660)),"^",8)]"":" ("_$P($G(^PSDRUG(+PSODRUG("IEN"),660)),"^",8)_")",1:" (  )")
"RTN","PSOORNEW",47,0)
 S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_": "_$S($G(PSONEW("QTY"))]"":PSONEW("QTY"),1:$P(OR0,"^",10))
"RTN","PSOORNEW",48,0)
 I $P($G(^PSDRUG(+$G(PSODRUG("IEN")),5)),"^")]"" D
"RTN","PSOORNEW",49,0)
 .S $P(RN," ",79)=" ",IEN=IEN+1
"RTN","PSOORNEW",50,0)
 .S ^TMP("PSOPO",$J,IEN,0)=$E(RN,$L("QTY DSP MSG: "_$P(^PSDRUG(PSODRUG("IEN"),5),"^"))+1,79)_"QTY DSP MSG: "_$P(^PSDRUG(PSODRUG("IEN"),5),"^") K RN
"RTN","PSOORNEW",51,0)
 S IEN=IEN+1
"RTN","PSOORNEW",52,0)
 I $P(OR0,"^",24) S ^TMP("PSOPO",$J,IEN,0)="   Provider ordered: days supply "_+$P(OR0,"^",22)_", quantity "_+$P(OR0,"^",10)_" & refills "_+$P(OR0,"^",11)
"RTN","PSOORNEW",53,0)
 E  S ^TMP("PSOPO",$J,IEN,0)="       Provider ordered "_+$P(OR0,"^",11)_" refills"
"RTN","PSOORNEW",54,0)
 D:$D(CLOZPAT) PQTY^PSOORFI4
"RTN","PSOORNEW",55,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(10)   # of Refills: "_$S($G(PSONEW("# OF REFILLS"))]"":PSONEW("# OF REFILLS"),1:$P(OR0,"^",11))_"               (11)   Routing: "_$S($G(PSONEW("MAIL/WINDOW"))="M":"MAIL",1:"WINDOW")
"RTN","PSOORNEW",56,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(12)         Clinic: "_PSORX("CLINIC")
"RTN","PSOORNEW",57,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(13)       Provider: "_PSONEW("PROVIDER NAME")
"RTN","PSOORNEW",58,0)
 D:$P(OR0,"^",24)!((+$G(PSODRUG("DEA"))>1)&(+$G(PSODRUG("DEA"))<6)) PRV^PSOORFI5($G(PSONEW("PROVIDER")),$G(PSODRUG("IEN")),$P(OR0,"^"))
"RTN","PSOORNEW",59,0)
 I $P($G(^VA(200,$S($G(PSONEW("PROVIDER")):PSONEW("PROVIDER"),1:$P(OR0,"^",5)),"PS")),"^",7)&($P($G(^("PS")),"^",8)) D
"RTN","PSOORNEW",60,0)
 .S IEN=IEN+1,PSONEW("COSIGNING PROVIDER")=$S($G(PSONEW("COSIGNING PROVIDER")):PSONEW("COSIGNING PROVIDER"),1:$P(^("PS"),"^",8))
"RTN","PSOORNEW",61,0)
 .S ^TMP("PSOPO",$J,IEN,0)="       Cos-Provider: "_$P(^VA(200,PSONEW("COSIGNING PROVIDER"),0),"^")
"RTN","PSOORNEW",62,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(14)         Copies: "_$S($G(PSONEW("COPIES")):PSONEW("COPIES"),1:1)
"RTN","PSOORNEW",63,0)
 S PSONEW("REMARKS")=$S($G(PSONEW("REMARKS"))]"":PSONEW("REMARKS"),$P(OR0,"^",17)="C":"Administered in Clinic.",1:"")
"RTN","PSOORNEW",64,0)
 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(15)        Remarks:"
"RTN","PSOORNEW",65,0)
 I $G(PSONEW("REMARKS"))]"" D
"RTN","PSOORNEW",66,0)
 .F SG=1:1:$L(PSONEW("REMARKS")) S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(PSONEW("REMARKS")," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " D
"RTN","PSOORNEW",67,0)
 ..S:$P(PSONEW("REMARKS")," ",SG)'="" ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(PSONEW("REMARKS")," ",SG)
"RTN","PSOORNEW",68,0)
 I $G(PSOSIGFL)!(PSODRUG("OI")'=$P(OR0,"^",8)) S PSONEW("CLERK CODE")=DUZ,PSORX("CLERK CODE")=$P(^VA(200,DUZ,0),"^"),VALMSG="This change will create a new prescription!"
"RTN","PSOORNEW",69,0)
 S $P(RN," ",35)=" ",IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="   Entry By: "_$P(^VA(200,PSONEW("CLERK CODE"),0),"^")_$E(RN,$L($P(^VA(200,PSONEW("CLERK CODE"),0),"^"))+1,35)
"RTN","PSOORNEW",70,0)
 S Y=$P(OR0,"^",12) X ^DD("DD") S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"Entry Date: "_$E($P(OR0,"^",12),4,5)_"/"_$E($P(OR0,"^",12),6,7)_"/"_$E($P(OR0,"^",12),2,3)_" "_$P(Y,"@",2) K RN
"RTN","PSOORNEW",71,0)
 I PSOLMC<2 D ^PSOLMPO1 S VALMBCK="Q",PSOLMC=0
"RTN","PSOORNEW",72,0)
 S:PSOLMC>1 VALMBCK="R"
"RTN","PSOORNEW",73,0)
 Q
"RTN","PSOORNEW",74,0)
ORCHK D PROVCOM^PSOORFI4,ORCHK^PSOORFI4
"RTN","PSOORNEW",75,0)
 Q
"RTN","PSOORNEW",76,0)
EDT D KV S DIR("A",1)="* Indicates which fields will create an new Order",DIR("A")="Select Field to Edit by number",DIR(0)="LO^1:15" D ^DIR Q:$D(DTOUT)!($D(DUOUT))
"RTN","PSOORNEW",77,0)
EDTSEL N LST,FLD,OUT D KV S OUT=0
"RTN","PSOORNEW",78,0)
 I +Y S LST=Y D FULL^VALM1 N PSODOSE M PSODOSE=PSONEW D  G DSPL
"RTN","PSOORNEW",79,0)
 .F FLD=1:1:$L(LST,",") Q:$P(LST,",",FLD)']""!(OUT)  D @(+$P(LST,",",FLD)) D:$P(LST,",",FLD)=8 REF D KV
"RTN","PSOORNEW",80,0)
 E  S VALMBCK="" Q
"RTN","PSOORNEW",81,0)
 Q
"RTN","PSOORNEW",82,0)
ACP ;
"RTN","PSOORNEW",83,0)
 N DIR,Y S Y=0
"RTN","PSOORNEW",84,0)
 I $G(ORD),+$P($G(^PS(52.41,+ORD,0)),"^",23)=1 D  Q:$D(DIRUT)!'Y  D EN1^ORCFLAG(+$P($G(^PS(52.41,ORD,0)),"^")) H 1
"RTN","PSOORNEW",85,0)
 . D FULL^VALM1
"RTN","PSOORNEW",86,0)
 . I '$D(^XUSEC("PSORPH",DUZ)) D  S Y=0 Q
"RTN","PSOORNEW",87,0)
 . . S DIR("A",1)="Order must be unflagged by a pharmacist before it can be finished."
"RTN","PSOORNEW",88,0)
 . . S DIR("A",2)=""
"RTN","PSOORNEW",89,0)
 . . S DIR(0)="E",DIR("A")="Enter RETURN to continue" W !,$C(7) D ^DIR
"RTN","PSOORNEW",90,0)
 . . S VALMBCK="R"
"RTN","PSOORNEW",91,0)
 . D KV
"RTN","PSOORNEW",92,0)
 . S DIR("A",1)="This Order is flagged. In order to finish it"
"RTN","PSOORNEW",93,0)
 . S DIR("A",2)="you must unflag it first."
"RTN","PSOORNEW",94,0)
 . S DIR("A",3)=""
"RTN","PSOORNEW",95,0)
 . S DIR(0)="Y",DIR("A")="Unflag Order",DIR("B")="NO"
"RTN","PSOORNEW",96,0)
 . W ! D ^DIR I $D(DIRUT)!'Y S VALMBCK="Q"
"RTN","PSOORNEW",97,0)
 I $G(ORD),+$P($G(^PS(52.41,+ORD,0)),"^",23)=1 Q
"RTN","PSOORNEW",98,0)
 ;
"RTN","PSOORNEW",99,0)
 I $D(CLOZPAT),+$G(PSONEW("QTY"))=0 S VALMSG="Unable to calculate the quantity, enter a quantity" G DSPL
"RTN","PSOORNEW",100,0)
 S (PSODIR("DFLG"),PSORX("DFLG"),PSODIR("QFLD"))=0,ACP=1 D ORCHK
"RTN","PSOORNEW",101,0)
 G:$G(PSONEW("QFLG")) DSPL
"RTN","PSOORNEW",102,0)
 I $G(PSODIR("DFLG"))!$G(PSORX("DFLG")) Q
"RTN","PSOORNEW",103,0)
 I $G(PSONEW("FLD"))!($G(PSODRUG("NAME"))']"")!('$O(SIG(0))) G DSPL
"RTN","PSOORNEW",104,0)
 I $G(PSODRUG("NAME"))]"",'$G(ORCHK)!($G(ORDRG)'=PSODRUG("NAME")) D  I $G(PSORX("DFLG")) D CLEAN^PSOVER1 G DSPL
"RTN","PSOORNEW",105,0)
 . D POST^PSODRG S:'$G(PSORX("DFLG")) ORCHK=1,ORDRG=PSODRUG("NAME")
"RTN","PSOORNEW",106,0)
 D:$$DS^PSSDSAPI&('$G(PSORX("DFLG"))) DOSCK^PSODOSUT("N") I $G(PSORX("DFLG")) D CLEAN^PSOVER1 G DSPL
"RTN","PSOORNEW",107,0)
 I '$D(PSONEW("RX #")) S PSOFROM="NEW",RTN=$S($P($G(PSOPAR),"^",7):"AUTO^PSONRXN",1:"MANUAL^PSONRXN") D @RTN Q:PSONEW("QFLG")  I '$P($G(PSOPAR),"^",7) S PSOX=PSONEW("RX #") D CHECK^PSONRXN
"RTN","PSOORNEW",108,0)
 D RXNCHK^PSOORNE1 I $G(PSONEW("QFLG")) S PSONEW("DFLG")=1 Q
"RTN","PSOORNEW",109,0)
 I DT>$$FMADD^XLFDT($P(OR0,"^",6),365) D EXPR^PSONEW2 G DSPL
"RTN","PSOORNEW",110,0)
 D STOP^PSONEW2,DISPLAY^PSONEW2,^PSONEWF
"RTN","PSOORNEW",111,0)
 I $G(PSOCPZ("DFLG")) W !!,"No action taken!",! K DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to continue" D ^DIR,KV K PSOCPZ("DFLG"),DRET,PSOANSQD S VALMBCK="Q" Q
"RTN","PSOORNEW",112,0)
 ;
"RTN","PSOORNEW",113,0)
 K PSOCPZ("DFLG") D KV S DIR(0)="Y",DIR("A")="Are you sure you want to Accept this Order",DIR("B")="NO" D ^DIR I $D(DIRUT) D KV K DRET,PSOANSQ,PSOANSQD S VALMBCK="Q" Q
"RTN","PSOORNEW",114,0)
 D KV I 'Y K PSOANSQ G DSPL
"RTN","PSOORNEW",115,0)
 I $G(PSONEW("MAIL/WINDOW"))["W" D:$P($G(PSOPAR),"^",12)  S BINGCRT="Y",BINGRTE="W",PSORX("MAIL/WINDOW")="WINDOW" K RTN
"RTN","PSOORNEW",116,0)
 .W ! K DIR,DIRUT S DIR(0)="52,35O"
"RTN","PSOORNEW",117,0)
 .S:$G(PSORX("METHOD OF PICK-UP"))]"" DIR("B")=PSORX("METHOD OF PICK-UP") D ^DIR I $D(DIRUT) K DIR,DIRUT Q
"RTN","PSOORNEW",118,0)
 .S (PSONEW("METHOD OF PICK-UP"),PSORX("METHOD OF PICK-UP"))=Y K X,Y
"RTN","PSOORNEW",119,0)
 S PSONEW("POE")=1 D EN^PSON52(.PSONEW) G:$G(PSONEW("DFLG")) ABORT D DCORD^PSONEW2 D:$G(PKI)=89802020 ALERT^PSOPKIV1
"RTN","PSOORNEW",120,0)
 ;saves drug allergy order chks pso*7*390
"RTN","PSOORNEW",121,0)
 I +$G(^TMP("PSODAOC",$J,1,0)) D
"RTN","PSOORNEW",122,0)
 .I $G(PSORX("DFLG")) K ^TMP("PSODAOC",$J) Q
"RTN","PSOORNEW",123,0)
 .S RXN=PSONEW("IRXN"),PSODAOC="Finished CPRS Rx "_$S($P(^PSRX(RXN,"STA"),"^")=4:"NON-VERIFIED ",1:"")_"Order Acceptance_OP"
"RTN","PSOORNEW",124,0)
 .D DAOC^PSONEW
"RTN","PSOORNEW",125,0)
 D NPSOSD^PSOUTIL(.PSONEW),FULL^VALM1 K PSORX("MAIL/WINDOW")
"RTN","PSOORNEW",126,0)
 D EOJ^PSONEW
"RTN","PSOORNEW",127,0)
ABORT S VALMBCK="Q",DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to Continue" D ^DIR,CLEAN^PSOVER1,KV
"RTN","PSOORNEW",128,0)
 Q
"RTN","PSOORNEW",129,0)
KV K DIRUT,DUOUT,DTOUT,DIR
"RTN","PSOORNEW",130,0)
 Q
"RTN","PSOORNEW",131,0)
REF D REF^PSOORFI4
"RTN","PSOORNEW",132,0)
 Q
"RTN","PSOORNEW",133,0)
1 I $P($G(OR0),"^",24) D  Q
"RTN","PSOORNEW",134,0)
 . W !!,"Digitally Signed Order - Orderable Item cannot be changed",! D PZ
"RTN","PSOORNEW",135,0)
 N PSOBDR,PSOBDRG S PSOBDRG=1 D 1^PSOORNW2 Q  ;oi
"RTN","PSOORNEW",136,0)
 ;
"RTN","PSOORNEW",137,0)
4 D INS^PSOORNW2 Q
"RTN","PSOORNEW",138,0)
 ;
"RTN","PSOORNEW",139,0)
3 I $G(LST)["3,",$P(OR0,"^",24) D  Q 
"RTN","PSOORNEW",140,0)
 . W !!,"Digitally Signed Order - Dose cannot be changed",! D PZ
"RTN","PSOORNEW",141,0)
 D DOSE^PSOORED4(.PSONEW) Q
"RTN","PSOORNEW",142,0)
 ;
"RTN","PSOORNEW",143,0)
6 D 4^PSOORNW2 Q  ;idt
"RTN","PSOORNEW",144,0)
 ;
"RTN","PSOORNEW",145,0)
7 D 5^PSOORNW2 Q  ;fdt
"RTN","PSOORNEW",146,0)
 ;
"RTN","PSOORNEW",147,0)
5 D 3^PSOORNW2 Q  ;pstat
"RTN","PSOORNEW",148,0)
 ;
"RTN","PSOORNEW",149,0)
13 I $P($G(OR0),"^",24) D  Q
"RTN","PSOORNEW",150,0)
 . W !!,"Digitally Signed Order - Provider cannot be changed",! D PZ
"RTN","PSOORNEW",151,0)
 D 12^PSOORNW2 Q  ;doc
"RTN","PSOORNEW",152,0)
 ;
"RTN","PSOORNEW",153,0)
12 D 11^PSOORNW2 Q  ;cli
"RTN","PSOORNEW",154,0)
 ;
"RTN","PSOORNEW",155,0)
2 N PSOCSIG I '$G(PSOBDRG) N PSOBDR,PSOBDRG S PSOBDRG=1
"RTN","PSOORNEW",156,0)
 N CPRN S CPRN=+$P($G(OR0),"^",24) D 2^PSOORNW1 Q:$G(PSOQFLG)  D EN^PSODIAG  ;drg/ICD
"RTN","PSOORNEW",157,0)
 I $G(PSOCSIG) K PSOCSIG G 3
"RTN","PSOORNEW",158,0)
 Q
"RTN","PSOORNEW",159,0)
 ;
"RTN","PSOORNEW",160,0)
9 D 8^PSOORNW2 Q  ;qty
"RTN","PSOORNEW",161,0)
 ;
"RTN","PSOORNEW",162,0)
8 N CPRN S CPRN=+$P($G(OR0),"^",24) D 7^PSOORNW2 Q  ;ds
"RTN","PSOORNEW",163,0)
 ;
"RTN","PSOORNEW",164,0)
10 I $P($G(OR0),"^",24) D  Q
"RTN","PSOORNEW",165,0)
 . W !!,"Digitally Signed Order - Refills cannot be changed",! D PZ
"RTN","PSOORNEW",166,0)
 D 9^PSOORNW2 Q  ;#rfs
"RTN","PSOORNEW",167,0)
 ;
"RTN","PSOORNEW",168,0)
14 D 13^PSOORNW2 Q  ;cop
"RTN","PSOORNEW",169,0)
 ;
"RTN","PSOORNEW",170,0)
11 D 10^PSOORNW2 Q  ;m/w
"RTN","PSOORNEW",171,0)
 ;
"RTN","PSOORNEW",172,0)
15 D 14^PSOORNW2 Q  ;rem
"RTN","PSOORNEW",173,0)
 ;
"RTN","PSOORNEW",174,0)
DRGMSG ;
"RTN","PSOORNEW",175,0)
 F SG=1:1:$L($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)) S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " D
"RTN","PSOORNEW",176,0)
 .S:$P($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)," ",SG)'="" ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)," ",SG)
"RTN","PSOORNEW",177,0)
 K SG
"RTN","PSOORNEW",178,0)
 Q
"RTN","PSOORNEW",179,0)
 ;
"RTN","PSOORNEW",180,0)
PZ ;
"RTN","PSOORNEW",181,0)
 N DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR W !
"RTN","PSOORNEW",182,0)
 Q
"RTN","PSOORNEW",183,0)
 ;
"RTN","PSOORNW1")
0^37^B44718806^B43950828
"RTN","PSOORNW1",1,0)
PSOORNW1 ;ISC BHAM/SAB - continuation of finish of new order ;5/10/07 8:30am
"RTN","PSOORNW1",2,0)
 ;;7.0;OUTPATIENT PHARMACY;**23,46,78,117,131,133,172,148,222,268,206,251,379,391**;DEC 1997;Build 13
"RTN","PSOORNW1",3,0)
 ;Reference ^YSCL(603.01 supported by DBIA 2697
"RTN","PSOORNW1",4,0)
 ;Reference ^PS(55 supported by DBIA 2228
"RTN","PSOORNW1",5,0)
 ;Reference ^PSDRUG( supported by DBIA 221
"RTN","PSOORNW1",6,0)
 ;Reference to $$GETNDC^PSSNDCUT supported by IA 4707
"RTN","PSOORNW1",7,0)
 ;
"RTN","PSOORNW1",8,0)
2 I $G(ORD),$G(ORSV) W !!,"Instructions: " D
"RTN","PSOORNW1",9,0)
 .S INST=0 F  S INST=$O(^PS(52.41,ORD,2,INST)) Q:'INST  S (MIG,INST(INST))=^PS(52.41,ORD,2,INST,0) D
"RTN","PSOORNW1",10,0)
 ..F SG=1:1:$L(MIG," ") W:$X+$L($P(MIG," ",SG)_" ")>IOM !?14 W $P(MIG," ",SG)_" "
"RTN","PSOORNW1",11,0)
 .S:'$D(PSODRUG("OI")) PSODRUG("OI")=$P(OR0,"^",8)
"RTN","PSOORNW1",12,0)
 .K INST,TY,MIG,SG
"RTN","PSOORNW1",13,0)
 S (PSDC,PSI)=0 W !!,"The following Drug(s) are available for selection:"
"RTN","PSOORNW1",14,0)
 F PSI=0:0 S PSI=$O(^PSDRUG("ASP",PSODRUG("OI"),PSI)) Q:'PSI  I $S('$D(^PSDRUG(PSI,"I")):1,'^("I"):1,DT'>^("I"):1,1:0),$S($P($G(^PSDRUG(PSI,2)),"^",3)'["O":0,1:1) D
"RTN","PSOORNW1",15,0)
 .S PSDC=PSDC+1 W !,PSDC_". "_$P(^PSDRUG(PSI,0),"^")_$S($P(^(0),"^",9):"     (N/F)",1:"")
"RTN","PSOORNW1",16,0)
 .S PSDC(PSDC)=PSI
"RTN","PSOORNW1",17,0)
 I PSDC=0 D
"RTN","PSOORNW1",18,0)
 . N X,DRG
"RTN","PSOORNW1",19,0)
 . S DRG=+$P($G(^PS(52.41,+$G(ORD),0)),"^",9)
"RTN","PSOORNW1",20,0)
 . S X=$$GET1^DIQ(50,DRG,100)
"RTN","PSOORNW1",21,0)
 . I X'="",(DT>X) D
"RTN","PSOORNW1",22,0)
 . . W !!,"   This Dispense Drug is now Inactive. You may select a"
"RTN","PSOORNW1",23,0)
 . . W !,"    new Orderable Item, or you can enter a new Order with"
"RTN","PSOORNW1",24,0)
 . . W !,"    an Active Drug.",!
"RTN","PSOORNW1",25,0)
 . E  W !!,"No drugs available!",!
"RTN","PSOORNW1",26,0)
 . K DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press return to continue"
"RTN","PSOORNW1",27,0)
 . D ^DIR K DIR
"RTN","PSOORNW1",28,0)
 G:'PSDC ETX I $G(PSOBDRG),'$D(PSOBDR) M PSOBDR=PSODRUG
"RTN","PSOORNW1",29,0)
 I PSDC'=1 D
"RTN","PSOORNW1",30,0)
 .I $P($G(^PSDRUG(+$G(PSODRUG("IEN")),2)),"^")=$G(PSODRUG("OI")) Q
"RTN","PSOORNW1",31,0)
 .K PSODRUG("NAME"),PSODRUG("IEN")
"RTN","PSOORNW1",32,0)
 W ! D KV S DIR(0)="N^1:"_PSDC,DIR("A")="Select Drug by number" D ^DIR
"RTN","PSOORNW1",33,0)
 I $D(DIRUT) S OUT=1 G EX
"RTN","PSOORNW1",34,0)
 D KV K PSOY S PSOY=PSDC(Y),PSOY(0)=^PSDRUG(PSOY,0),PSOCSIG=0
"RTN","PSOORNW1",35,0)
 I $G(PSOBDR("IEN")),PSOBDR("IEN")'=+PSOY D:$G(ORD)  G:$D(DIRUT) EX
"RTN","PSOORNW1",36,0)
 .D KV S DIR(0)="Y",DIR("B")="YES",DIR("A",1)="You have changed the dispense drug from",DIR("A",2)=PSOBDR("NAME")_" to "_$P(^PSDRUG(+PSOY,0),"^")_".",DIR("A")="Do You want to Edit the SIG"
"RTN","PSOORNW1",37,0)
 .D ^DIR I $D(DIRUT) S OUT=1 Q
"RTN","PSOORNW1",38,0)
 .S:Y PSOCSIG=1
"RTN","PSOORNW1",39,0)
 .I 'Y D  Q:$D(DIRUT)
"RTN","PSOORNW1",40,0)
 ..I $P($G(OR0),"^",24) S (OUT,DIRUT)=1 Q
"RTN","PSOORNW1",41,0)
 ..D URX I $D(DIRUT) S OUT=1
"RTN","PSOORNW1",42,0)
 D KV
"RTN","PSOORNW1",43,0)
CT1 I $P($G(^PSDRUG(PSOY,"CLOZ1")),"^")="PSOCLO1",'$O(^YSCL(603.01,"C",PSODFN,0)) D  Q
"RTN","PSOORNW1",44,0)
 .S VALMSG="Patient Not Registered in Clozapine Program",VALMBCK="Q" K PSOY,PSDC
"RTN","PSOORNW1",45,0)
 I $G(ORD) S ^TMP("PSORXPO",$J,ORD,0)=1
"RTN","PSOORNW1",46,0)
 S PSODRUG("IEN")=+PSOY,PSODRUG("VA CLASS")=$P(PSOY(0),"^",2),PSODRUG("NAME")=$P(PSOY(0),"^")
"RTN","PSOORNW1",47,0)
 S PSODRUG("NDF")=$S($G(^PSDRUG(+PSOY,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:0)
"RTN","PSOORNW1",48,0)
 S PSODRUG("MAXDOSE")=$P(PSOY(0),"^",4),PSODRUG("DEA")=$P(PSOY(0),"^",3),PSODRUG("CLN")=$S($D(^PSDRUG(+PSOY,"ND")):+$P(^("ND"),"^",6),1:0)
"RTN","PSOORNW1",49,0)
 S PSODRUG("SIG")=$P(PSOY(0),"^",5),PSODRUG("NDC")=$$GETNDC^PSSNDCUT(+PSOY,$G(PSOSITE)),PSODRUG("STKLVL")=$G(^PSDRUG(+PSOY,660.1))
"RTN","PSOORNW1",50,0)
 S PSODRUG("DAW")=+$$GET1^DIQ(50,+PSOY,81)
"RTN","PSOORNW1",51,0)
 ;I $G(^PSDRUG(+PSOY,660))']"" D:'$G(PSOFIN)&('$G(PSOCOPY)) POST^PSODRG G ETX
"RTN","PSOORNW1",52,0)
 S PSOX1=$G(^PSDRUG(+PSOY,660)),PSODRUG("COST")=$P($G(PSOX1),"^",6),PSODRUG("UNIT")=$P($G(PSOX1),"^",8),PSODRUG("EXPIRATION DATE")=$P($G(PSOX1),"^",9)
"RTN","PSOORNW1",53,0)
 ;D:'$G(PSOFIN)&('$G(PSOCOPY)) POST^PSODRG
"RTN","PSOORNW1",54,0)
 I $G(PSORX("DFLG")) K PSODRUG N LST Q:$G(PSOAC)!($G(NEWEDT))  D DSPL^PSOORFI1 S VALMBCK="Q" Q
"RTN","PSOORNW1",55,0)
ETX D REF S VALMBCK="R" I 'PSDC S VALMSG="NO dispense drugs tied to this orderable item!" S PSOQFLG=1
"RTN","PSOORNW1",56,0)
TX D KV K PSDC,PSI,X,Y,PSOX1,PSOY
"RTN","PSOORNW1",57,0)
 Q
"RTN","PSOORNW1",58,0)
EX M PSODRUG=PSOBDR K PSOBDR,PSOBDRG S PSOQFLG=1,VALMBCK="R" D MP1^PSOOREDX
"RTN","PSOORNW1",59,0)
 D TX Q
"RTN","PSOORNW1",60,0)
URX D KV S DIR(0)="Y",DIR("A")="Are You Sure You Want to Update Rx",DIR("B")="Yes"
"RTN","PSOORNW1",61,0)
 D ^DIR S:$D(DIRUT)!('Y) DIRUT=1
"RTN","PSOORNW1",62,0)
 I Y S ^TMP("PSORXPO",$J,ORD,0)=1 ;screens 4 order checks
"RTN","PSOORNW1",63,0)
 Q
"RTN","PSOORNW1",64,0)
REF Q:'$D(PSODRUG("DEA"))!('$G(PSODRUG("IEN")))!('$G(^PS(55,PSODFN,"PS")))
"RTN","PSOORNW1",65,0)
 S PSONEW("CS")=0,PTRF=$S(+$G(^PS(55,PSODFN,"PS"))&($P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",4)]""):$P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",4),1:5)
"RTN","PSOORNW1",66,0)
 F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSONEW("CS"),"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSONEW("CS"),"^",2)=1
"RTN","PSOORNW1",67,0)
 I $P($G(PSONEW("CS")),"^",2)=1 S PSONEW("# OF REFILLS")=0 Q
"RTN","PSOORNW1",68,0)
 I +PSONEW("CS") D
"RTN","PSOORNW1",69,0)
 .S PSOX=$S($P($G(OR0),"^",11)>5:5,1:+$P($G(OR0),"^",11))
"RTN","PSOORNW1",70,0)
 .S PSOX=$S(PSOX>PTRF:PTRF,1:PSOX)
"RTN","PSOORNW1",71,0)
 .S PSONEW("# OF REFILLS")=PSOX
"RTN","PSOORNW1",72,0)
 E  D
"RTN","PSOORNW1",73,0)
 .S PSOX=$S($P($G(OR0),"^",11)'>PTRF&($P($G(OR0),"^",11)'>11):11,1:PTRF)
"RTN","PSOORNW1",74,0)
 I '$D(CLOZPAT) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F")!(PSODRUG("DEA")[1)!(PSODRUG("DEA")[2) S PSOX=0,PSONEW("# OF REFILLS")=0 K PSDY,PSDY1,PTRF Q
"RTN","PSOORNW1",75,0)
 I $D(CLOZPAT) S (PSOX,PSONEW("N# REF"),PSONEW("# OF REFILLS"))=$S(CLOZPAT=2&($G(PSONEW("# OF REFILLS"))>2):3,CLOZPAT&($G(PSONEW("# OF REFILLS"))>1):1,1:0),PSONEW("DAYS SUPPLY")=7,ORCHK=1 K PSDY,PSDY1,PTRF Q
"RTN","PSOORNW1",76,0)
 S PSONEW("# OF REFILLS")=$S($G(PSONEW("# OF REFILLS"))'="":$G(PSONEW("# OF REFILLS")),1:PSOX) K PSDY,PSDY1,PTRF
"RTN","PSOORNW1",77,0)
 Q
"RTN","PSOORNW1",78,0)
EDNEW K PSMAX,PSFMAX F DEA=1:1 Q:$E(PSODEA,DEA)=""  I $E(+PSODEA,DEA)>1,$E(+PSODEA,DEA)<6 S CS=1
"RTN","PSOORNW1",79,0)
 I CS D
"RTN","PSOORNW1",80,0)
 .S PSOX1=$S(PTRF>5:5,1:PTRF),PSOX=$S(PSOX1=5:5,1:PSOX1)
"RTN","PSOORNW1",81,0)
 .S PSOX=$S('PSOX:0,PSDAYS=90:1,1:PSOX),PSDY1=$S(PSDAYS<60:5,PSDAYS'<60&(PSDAYS'>89):2,PSDAYS=90:1,1:0) S MAX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
"RTN","PSOORNW1",82,0)
 E  D
"RTN","PSOORNW1",83,0)
 .S PSOX1=PTRF,PSOX=$S(PSOX1=11:11,1:PSOX1),PSOX=$S('PSOX:0,PSDAYS=90:3,1:PSOX)
"RTN","PSOORNW1",84,0)
 .S PSDY1=$S(PSDAYS<60:11,PSDAYS'<60&(PSDAYS'>89):5,PSDAYS=90:3,1:0) S MAX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
"RTN","PSOORNW1",85,0)
 I PSRF>MAX D
"RTN","PSOORNW1",86,0)
 .W $C(7),!!,PSRF_" refills are not correct for a "_PSDAYS_" day supply.",!,"Please enter correct # of refills for a "_PSDAYS_" day supply. Max refills allowed is "_MAX_".",!
"RTN","PSOORNW1",87,0)
 .S (PSMAX("MAX"),PSFMAX("MAX"))=MAX,(PSMAX("RF"),PSFMAX("RF"))=PSRF,(PSMAX("DAYS"),PSFMAX("DAYS"))=PSDAYS,(PSMAX,PSFMAX)=1
"RTN","PSOORNW1",88,0)
 K PSTMAX D EDSTAT
"RTN","PSOORNW1",89,0)
 Q
"RTN","PSOORNW1",90,0)
STATDAY K PSMAX,PSRMAX,PSFMAX,PSTMAX S PSDAYS=$P(^PSRX(DA,0),"^",8),PSRF=$P(^PSRX(DA,0),"^",9),PTST=$P(^PS(53,X,0),"^"),PTDY=$P(^(0),"^",3),PTRF=$P(^(0),"^",4)
"RTN","PSOORNW1",91,0)
EDSTAT I PSRF>PTRF W !,$C(7),PSRF_" refills are greater than "_PTRF_" allowed for "_$P(PTST,"^")_" Rx Patient Status.",! S PSTMAX=1,PSTMAX("PTRF")=PTRF,PSTMAX("PSRF")=PSRF,PSTMAX("PT")=$P(PTST,"^")
"RTN","PSOORNW1",92,0)
 Q
"RTN","PSOORNW1",93,0)
OERF S DIR(0)="N^0:"_PSOX,DIR("A")="# OF REFILLS"
"RTN","PSOORNW1",94,0)
 S DIR("B")=$S($G(POERR):PSONEW("# OF REFILLS"),$G(PSONEW("N# REF"))]"":PSONEW("N# REF"),$G(PSONEW("# OF REFILLS"))]"":PSONEW("# OF REFILLS"),$G(PSOX1)]""&(PSOX>PSOX1):PSOX1,1:PSOX)
"RTN","PSOORNW1",95,0)
 S DIR("?")="Enter a whole number.  The maximum is set by the Rx Patient Status because there is no Dispense Drug."
"RTN","PSOORNW1",96,0)
 D ^DIR G:$D(DIRUT) REFX
"RTN","PSOORNW1",97,0)
 S (PSONEW("N# REF"),PSONEW("# OF REFILLS"))=Y
"RTN","PSOORNW1",98,0)
REFX S:'$D(PSONEW("# OF REFILLS")) PSONEW("# OF REFILLS")=$S($G(PSONEW("N# REF"))]"":PSONEW("N# REF"),$G(PSOX1)]""&($G(PSOX)>PSOX1):PSOX1,1:PSOX)
"RTN","PSOORNW1",99,0)
 K X,Y,PSOX,PSOX1,PSDY,PSDY1,DEA
"RTN","PSOORNW1",100,0)
KV K DIR,DIRUT,DUOUT,DTOUT
"RTN","PSOORNW1",101,0)
 Q
"RTN","PSOPKIV1")
0^16^B98820890^B24905517
"RTN","PSOPKIV1",1,0)
PSOPKIV1 ;BHAM ISC/MHA - validate PKI cert. ; 05/09/2002  8:15 am
"RTN","PSOPKIV1",2,0)
 ;;7.0;OUTPATIENT PHARMACY;**131,146,223,148,249,391**;DEC 1997;Build 13
"RTN","PSOPKIV1",3,0)
 ;Ref. to ^ORDEA is supported by DBIA 5709
"RTN","PSOPKIV1",4,0)
 ;Ref. to ^ORB supported by DBIA 1362
"RTN","PSOPKIV1",5,0)
 ;Ref. to ^XUSSPKI supported by DBIA 3539
"RTN","PSOPKIV1",6,0)
CER ;
"RTN","PSOPKIV1",7,0)
 N PKIRT
"RTN","PSOPKIV1",8,0)
 D VERIFY(.PKIRT,ORD)
"RTN","PSOPKIV1",9,0)
 S PKI=+PKIRT I PKI=1!(PKI=89802020) D  Q
"RTN","PSOPKIV1",10,0)
 . S PKI1=1,VALMSG="Digitally Signed Order",PKIE="Processing "_VALMSG
"RTN","PSOPKIV1",11,0)
 . I PKI=89802020 S PKIE=PKIE_": "_$P($T(@($E(PKI,7,8))),";;",2)
"RTN","PSOPKIV1",12,0)
 I PKI<2 S VALMSG=$P(PKIRT,"^",2) Q
"RTN","PSOPKIV1",13,0)
 S PKI1=$S(PKI>89802014&(PKI<89802020)!((PKI>89802020)&(PKI<89802031)):2,1:1)
"RTN","PSOPKIV1",14,0)
 S PKIE="Digital Signature Failed: "_$P($T(@($E(PKI,7,8))),";;",2)
"RTN","PSOPKIV1",15,0)
 I PKI1=2 D
"RTN","PSOPKIV1",16,0)
 .S VALMSG="Signature Failed: "_$P($T(@($E(PKI,7,8))),";;",2)
"RTN","PSOPKIV1",17,0)
 .S PKIE=PKIE_" - Order Auto Discontinued"
"RTN","PSOPKIV1",18,0)
 S:$L(PKIE)>80 PKIE=$E(PKIE,1,80)
"RTN","PSOPKIV1",19,0)
 Q
"RTN","PSOPKIV1",20,0)
L1 ;
"RTN","PSOPKIV1",21,0)
 S PKID=1,IEN=IEN+1,^TMP($S($G(ST)=1:"PSOAO",1:"PSOPO"),$J,IEN,0)=PKIE
"RTN","PSOPKIV1",22,0)
 Q
"RTN","PSOPKIV1",23,0)
ERR(ER) ;
"RTN","PSOPKIV1",24,0)
 Q:'ER
"RTN","PSOPKIV1",25,0)
 N ERM S ERM=$P($T(@($E(ER,7,8))),";;",2) I ERM]"" Q "Signature Failed: "_ERM
"RTN","PSOPKIV1",26,0)
 Q ""
"RTN","PSOPKIV1",27,0)
REA ;
"RTN","PSOPKIV1",28,0)
 D KV^PSOVER1
"RTN","PSOPKIV1",29,0)
 W ! S DIR("A")="Enter Override Reason ",DIR(0)="F^5:70",DIR("?")="Free text reason must be entered, should be between 5 to 70 characters and must not contain embedded up-arrow, e.g. Spoke with the Provider."
"RTN","PSOPKIV1",30,0)
 S:$G(PKIR)]"" DIR("B")=PKIR D ^DIR S:'$D(DIRUT) PKIR=Y
"RTN","PSOPKIV1",31,0)
 I $D(DIRUT) K PKIR I $D(OR0) S:$P(OR0,"^",3)="RNW" PSONEW("QFLG")=1 S:$P(OR0,"^",3)="NW" PSORX("DFLG")=1
"RTN","PSOPKIV1",32,0)
 D KV^PSOVER1 K Y Q
"RTN","PSOPKIV1",33,0)
ACT(DA) ;
"RTN","PSOPKIV1",34,0)
 Q:'DA
"RTN","PSOPKIV1",35,0)
 N I,J D AR
"RTN","PSOPKIV1",36,0)
 S ^PSRX(DA,"A",0)="^52.3DA^"_J_"^"_J,^PSRX(DA,"A",J,0)=%_"^K^"_DUZ_"^0^INVALID PKI CERT. "_PKI
"RTN","PSOPKIV1",37,0)
 S ^PSRX(DA,"A",J,2,1,0)=PKIR,^PSRX(DA,"A",J,2,0)="^52.34A^1^1"
"RTN","PSOPKIV1",38,0)
 K PKIR Q
"RTN","PSOPKIV1",39,0)
 ;
"RTN","PSOPKIV1",40,0)
AR ;
"RTN","PSOPKIV1",41,0)
 S (I,J)=0 F  S I=$O(^PSRX(DA,"A",I)) Q:'I  S J=I
"RTN","PSOPKIV1",42,0)
 S J=J+1 D NOW^%DTC Q
"RTN","PSOPKIV1",43,0)
DCP ;
"RTN","PSOPKIV1",44,0)
 Q:'$D(^PS(52.41,ORD,0))  N PKIOR,PKIORM
"RTN","PSOPKIV1",45,0)
 K ^PS(52.41,"AOR",$P(^PS(52.41,ORD,0),"^",2),+$P($G(^PS(52.41,ORD,"INI")),"^"),ORD),^PS(52.41,"AD",$P(^PS(52.41,ORD,0),"^",12),+$P($G(^PS(52.41,ORD,"INI")),"^"),ORD)
"RTN","PSOPKIV1",46,0)
 S $P(^PS(52.41,ORD,0),"^",3)="DC"
"RTN","PSOPKIV1",47,0)
 S PKIE=$P(PKIE," - ")_" - "_PKI,$P(^PS(52.41,ORD,4),"^")=PKIE
"RTN","PSOPKIV1",48,0)
 S PKIOR=$E(PKI,7,8)
"RTN","PSOPKIV1",49,0)
 S PKIORM=$S(PKIOR=16:"16:Order has been modified. Resubmit or contact Pharmacy.",PKIOR=17:"17:DEA Certificate revoked. Resubmit or contact Pharmacy.",1:PKIE)
"RTN","PSOPKIV1",50,0)
 D EN^PSOHLSN($P(^PS(52.41,ORD,0),"^"),"OC",PKIORM,"A")
"RTN","PSOPKIV1",51,0)
 D ^PSOPKIV2
"RTN","PSOPKIV1",52,0)
 Q
"RTN","PSOPKIV1",53,0)
 ;
"RTN","PSOPKIV1",54,0)
DCV ;
"RTN","PSOPKIV1",55,0)
 W ! D KV^PSOVER1 K PKIR S DIR(0)="Y",DIR("B")="N",DIR("A",1)="Digitally signed Schedule II Rx cannot be deleted, it can only be D/Ced."
"RTN","PSOPKIV1",56,0)
 S DIR("A")="Are you sure you want to D/C this Rx: " D ^DIR,KV^PSOVER1
"RTN","PSOPKIV1",57,0)
 I 'Y S VALMSG="No Action Taken!",VALMBCK="R" Q
"RTN","PSOPKIV1",58,0)
 S:'$D(INCOM) INCOM="DCed by Pharmacy for PKI" S DIR("B")=INCOM
"RTN","PSOPKIV1",59,0)
 ;
"RTN","PSOPKIV1",60,0)
 W ! S DIR("A")="Reason for D/Cing",DIR(0)="F^5:75",DIR("?")="Reason must be entered and should be 5 to 75 characters and must not contain embedded uparrow"
"RTN","PSOPKIV1",61,0)
 D ^DIR I $D(DIRUT) D KV^PSOVER1 S VALMSG="No Action Taken!",VALMBCK="R" Q
"RTN","PSOPKIV1",62,0)
 S PKIR=Y D KV^PSOVER1
"RTN","PSOPKIV1",63,0)
DCV0 Q:'$D(^PS(52.4,DA,0))
"RTN","PSOPKIV1",64,0)
 S $P(^PSRX(DA,"STA"),"^")=12,$P(^PSRX(DA,3),"^",5)=DT
"RTN","PSOPKIV1",65,0)
 D REVERSE^PSOBPSU1(DA,,"DC",7),CAN^PSOTPCAN(DA) N I,J D AR
"RTN","PSOPKIV1",66,0)
 S ^PSRX(DA,"A",J,0)=%_"^C^"_DUZ_"^0^Discontinued during verification"
"RTN","PSOPKIV1",67,0)
 S J=J+1 D ADR
"RTN","PSOPKIV1",68,0)
 N PKIX S PKIX=DA D EN^PSOHLSN1(DA,"OD","",PKIR,PSONOOR)
"RTN","PSOPKIV1",69,0)
 S DA=PKIX S DIK="^PS(52.4," D ^DIK K DIK
"RTN","PSOPKIV1",70,0)
 Q
"RTN","PSOPKIV1",71,0)
 ;
"RTN","PSOPKIV1",72,0)
DCV1 N PKIR,PSONOOR,DA S DA=PSONV,PKIR=$P($G(PKIE),"-")_" - "_PKI,PSONOOR="A" D DCV0
"RTN","PSOPKIV1",73,0)
 Q
"RTN","PSOPKIV1",74,0)
ADR ;
"RTN","PSOPKIV1",75,0)
 S ^PSRX(DA,"A",0)="^52.3DA^"_J_"^"_J
"RTN","PSOPKIV1",76,0)
 S ^PSRX(DA,"A",J,0)=%_"^K^"_DUZ_"^0^Digitally signed"
"RTN","PSOPKIV1",77,0)
 S ^PSRX(DA,"A",J,2,1,0)=$S($G(PKIR)]"":PKIR,1:"Digitally signed order Discontinued"),^PSRX(DA,"A",J,2,0)="^52.34A^1^1"
"RTN","PSOPKIV1",78,0)
 Q
"RTN","PSOPKIV1",79,0)
RV ;
"RTN","PSOPKIV1",80,0)
 N TY,T,T1,T2,MIG,SG
"RTN","PSOPKIV1",81,0)
 S (T,T2)=0
"RTN","PSOPKIV1",82,0)
 F  S T=$O(^PS(52.41,ORD,"OBX",T)) Q:'T  D
"RTN","PSOPKIV1",83,0)
 .S T1=0,$P(TY(T2)," ",23)=" "
"RTN","PSOPKIV1",84,0)
 .F  S T1=$O(^PS(52.41,ORD,"OBX",T,2,T1)) Q:'T1  D
"RTN","PSOPKIV1",85,0)
 ..S MIG=^PS(52.41,ORD,"OBX",T,2,T1,0)
"RTN","PSOPKIV1",86,0)
 ..F SG=1:1:$L(MIG," ") S:$L(TY(T2)_" "_$P(MIG," ",SG))>80 T2=T2+1,$P(TY(T2)," ",23)=" " S TY(T2)=$G(TY(T2))_" "_$P(MIG," ",SG)
"RTN","PSOPKIV1",87,0)
 .S T2=T2+4
"RTN","PSOPKIV1",88,0)
 Q
"RTN","PSOPKIV1",89,0)
 ;
"RTN","PSOPKIV1",90,0)
VERIFY(RET,PSIEN)       ;Verify PKI Data
"RTN","PSOPKIV1",91,0)
 ;PSIEN = IEN of file 52.41 ;ORIFN;ACTION - NOTE: if no ACTION then 1 (new order) is assumed
"RTN","PSOPKIV1",92,0)
 ;Returned values: "1" if digital signature verifies
"RTN","PSOPKIV1",93,0)
 ;                 "-1^error message" if DS fails during initial parameter checking
"RTN","PSOPKIV1",94,0)
 ;                 "898020xx^message" if DS fails during verification
"RTN","PSOPKIV1",95,0)
 ;
"RTN","PSOPKIV1",96,0)
 N PSO0,DFN,PSIG,I,INFO,INF1,DEA,INST,HASH,DATE
"RTN","PSOPKIV1",97,0)
 I $G(PSIEN)="" S RET="-1^Invalid order number" Q
"RTN","PSOPKIV1",98,0)
 K ^TMP("PSOPKIDATA",$J)
"RTN","PSOPKIV1",99,0)
 S PSO0=$G(^PS(52.41,PSIEN,0))
"RTN","PSOPKIV1",100,0)
 S ^TMP("PSOPKIDATA",$J,"ISSUANCE DATE",1)=$$FMTE^XLFDT($P($P(PSO0,"^",6),"."))
"RTN","PSOPKIV1",101,0)
 ;patient inf
"RTN","PSOPKIV1",102,0)
 S DFN=$P(PSO0,"^",2) D DEM^VADPT,ADD^VADPT
"RTN","PSOPKIV1",103,0)
 S ^TMP("PSOPKIDATA",$J,"PATIENT NAME",2)=VADM(1)
"RTN","PSOPKIV1",104,0)
 S ^TMP("PSOPKIDATA",$J,"PATIENT ADDRESS",3)=VAPA(1)_"^"_VAPA(2)_"^"_VAPA(3)_"^"_VAPA(4)_"^"_$P(VAPA(5),"^")_"^"_$P(VAPA(5),"^",2)_"^"_VAPA(6)_"^"_VAPA(7)
"RTN","PSOPKIV1",105,0)
 S ^TMP("PSOPKIDATA",$J,"QUANTITY",5)=$P(PSO0,"^",10)
"RTN","PSOPKIV1",106,0)
 K ^TMP($J,"ORDEA")
"RTN","PSOPKIV1",107,0)
 D ARCHIVE^ORDEA(+PSO0)
"RTN","PSOPKIV1",108,0)
 ;POS DOSE
"RTN","PSOPKIV1",109,0)
 N J,INF0,INF1,PSIG
"RTN","PSOPKIV1",110,0)
 S J=0 F  S J=$O(^PS(52.41,PSIEN,1,J)) Q:'J  D
"RTN","PSOPKIV1",111,0)
 .S INF0=$G(^PS(52.41,PSIEN,9,J,0)),INF1=$G(^PS(52.41,PSIEN,1,J,1))
"RTN","PSOPKIV1",112,0)
 .S PSIG=INF0_"|"_$P(INF1,"^")_"|"_$P(INF1,"^",2)_"|"_$P(INF1,"^",6)_"|"_$P(INF1,"^",8)
"RTN","PSOPKIV1",113,0)
 .S ^TMP("PSOPKIDATA",$J,"DIRECTIONS",6,J)=PSIG
"RTN","PSOPKIV1",114,0)
 I +$P(PSO0,"^",9),+$P(PSO0,"^",25) S ^TMP("PSOPKIDATA",$J,"DRUG NAME",4)=$$GET1^DIQ(50,$P(PSO0,"^",9),.01)
"RTN","PSOPKIV1",115,0)
 S DEA=$P($G(^TMP($J,"ORDEA",+PSO0,2)),"^")
"RTN","PSOPKIV1",116,0)
 ;S ^TMP("PSOPKIDATA",$J,"DETOX NUMBER",7)=$$DETOX^XUSER($P(PSO0,"^",5))
"RTN","PSOPKIV1",117,0)
 S ^TMP("PSOPKIDATA",$J,"PROVIDER NAME",8)=$$GET1^DIQ(200,$P(PSO0,"^",5),.01)
"RTN","PSOPKIV1",118,0)
 I $D(^TMP($J,"ORDEA",+PSO0,3)) S ^TMP("PSOPKIDATA",$J,"PROVIDER ADDRESS",9)=$P(^(3),"^",2,6)
"RTN","PSOPKIV1",119,0)
 E  D INSTAD
"RTN","PSOPKIV1",120,0)
 K ^TMP($J,"ORDEA")
"RTN","PSOPKIV1",121,0)
 D KVA^VADPT
"RTN","PSOPKIV1",122,0)
 S ^TMP("PSOPKIDATA",$J,"DEA NUMBER",10)=DEA
"RTN","PSOPKIV1",123,0)
 S ^TMP("PSOPKIDATA",$J,"ORDER NUMBER",11)=$P(PSO0,"^")
"RTN","PSOPKIV1",124,0)
 S HASH=$$HASHRTN^ORDEA($P(PSO0,"^"))
"RTN","PSOPKIV1",125,0)
 I '$L(HASH) S RET="-1^Order has no PKI Hash" G VQT
"RTN","PSOPKIV1",126,0)
 S DATE=$$FMTE^XLFDT($P($P(PSO0,"^",6),"."))
"RTN","PSOPKIV1",127,0)
 I '$L(DATE) S RET="-1^No date associated with order" G VQT
"RTN","PSOPKIV1",128,0)
 S RET=$$VERIFY^XUSSPKI(HASH,$NA(^TMP("PSOPKIDATA",$J)))
"RTN","PSOPKIV1",129,0)
 I RET="OK"!(RET["No error found for this certificate or chain") S RET=1 G VQT
"RTN","PSOPKIV1",130,0)
 N ECD S ECD=898020
"RTN","PSOPKIV1",131,0)
 I RET[ECD S RET=$P(RET,"^",2) G VQT
"RTN","PSOPKIV1",132,0)
 I RET["not time-valid" S RET=ECD_"20" G VQT
"RTN","PSOPKIV1",133,0)
 I RET["has been revoked" S RET=ECD_"17" G VQT
"RTN","PSOPKIV1",134,0)
 I RET["does not have a valid signature" S RET=ECD_"22" G VQT
"RTN","PSOPKIV1",135,0)
 I RET["not properly time-nested" S RET=ECD_"23" G VQT
"RTN","PSOPKIV1",136,0)
 I RET["not valid in its proposed usage" S RET=ECD_"24" G VQT
"RTN","PSOPKIV1",137,0)
 I RET["based on an untrusted root" S RET=ECD_"25" G VQT
"RTN","PSOPKIV1",138,0)
 I RET["certificates in the certificate chain is unknown" S RET=ECD_"26" G VQT
"RTN","PSOPKIV1",139,0)
 I RET["authority that the original certificate had certified" S RET=ECD_"27" G VQT
"RTN","PSOPKIV1",140,0)
 I RET["certificate chain is not complete" S RET=ECD_"28" G VQT
"RTN","PSOPKIV1",141,0)
 I RET["this chain did not have a valid signature" S RET=ECD_"29" G VQT
"RTN","PSOPKIV1",142,0)
 I RET["not valid for this usage" S RET=ECD_"30" G VQT
"RTN","PSOPKIV1",143,0)
VQT ;
"RTN","PSOPKIV1",144,0)
 K ^TMP("PSOPKIDATA",$J)
"RTN","PSOPKIV1",145,0)
 Q
"RTN","PSOPKIV1",146,0)
 ;
"RTN","PSOPKIV1",147,0)
INSTAD ;
"RTN","PSOPKIV1",148,0)
 S INST=$P($G(^PS(52.41,PSIEN,"INI")),"^")
"RTN","PSOPKIV1",149,0)
 D GETS^DIQ(4,INST,".01;1.01;1.02;1.03;1.04;.02","E","VADR")
"RTN","PSOPKIV1",150,0)
 S VADD(1)=$G(VADR(4,INST_",",.01,"E")),VADD(2)=$G(VADR(4,INST_",",1.01,"E")),VADD(3)=$G(VADR(4,INST_",",1.02,"E"))
"RTN","PSOPKIV1",151,0)
 S VADD(4)=$G(VADR(4,INST_",",1.03,"E")),VADD(5)=$G(VADR(4,INST_",",.02,"E")),VADD(6)=$G(VADR(4,INST_",",1.04,"E"))
"RTN","PSOPKIV1",152,0)
 S ^TMP("PSOPKIDATA",$J,"PROVIDER ADDRESS",9)=VADD(1)_"^"_VADD(2)_"^"_VADD(3)_"^"_VADD(4)_"^"_VADD(5)_"^"_VADD(6)
"RTN","PSOPKIV1",153,0)
 Q
"RTN","PSOPKIV1",154,0)
 ;
"RTN","PSOPKIV1",155,0)
HSHCHK(ARET,PNP) ;Compares digitally signed archived data in file #101.52 against data in OP pending file #52.41
"RTN","PSOPKIV1",156,0)
 ;PSO*7*391/JAM
"RTN","PSOPKIV1",157,0)
 ;Input - PNP  - Pending file IEN
"RTN","PSOPKIV1",158,0)
 ;     
"RTN","PSOPKIV1",159,0)
 ;Output - returns 1 if the archived data matches the pending file
"RTN","PSOPKIV1",160,0)
 ;                 0 if initial parameter checking fails
"RTN","PSOPKIV1",161,0)
 ;                -1 if comparison fails; and return array with failed items
"RTN","PSOPKIV1",162,0)
 ;
"RTN","PSOPKIV1",163,0)
 N DFN,PND0,DRGNM,DEA,DETOX,DFN,J,I,INST,NAM,SIGFL,DOSE,DOSEP,DOSEX,DFRM,TMP,VADD,VADR,INF0,INF1,ASIG,PSIG,ORP,ND
"RTN","PSOPKIV1",164,0)
 I $G(PNP)="" S ARET=0 Q ARET
"RTN","PSOPKIV1",165,0)
 S PND0=$G(^PS(52.41,PNP,0)) I PND0="" S ARET=0 Q ARET
"RTN","PSOPKIV1",166,0)
 S ORP=$P(PND0,"^") I ORP="" S ARET=0 Q ARET
"RTN","PSOPKIV1",167,0)
 ;get archived data from CPRS
"RTN","PSOPKIV1",168,0)
 K ^TMP($J,"ORDEA")
"RTN","PSOPKIV1",169,0)
 D ARCHIVE^ORDEA(ORP)
"RTN","PSOPKIV1",170,0)
 I '$D(^TMP($J,"ORDEA")) S ARET=0 Q ARET
"RTN","PSOPKIV1",171,0)
 F I=1:1:5 S TMP(I)=$G(^TMP($J,"ORDEA",ORP,I))
"RTN","PSOPKIV1",172,0)
 I $P($P(PND0,"^",6),".")'=$P(TMP(1),"^",2) S ARET=-1,ARET("ISSUANCE DATE")=$P(TMP(1),"^",2)_"^"_$P($P(PND0,"^",6),".")
"RTN","PSOPKIV1",173,0)
 S DRGNM=$$GET1^DIQ(50,$P(PND0,"^",9),.01)
"RTN","PSOPKIV1",174,0)
 I DRGNM'=$P(TMP(1),"^",3) S ARET=-1,ARET("DRUG NAME")=$P(TMP(1),"^",3)_"^"_DRGNM
"RTN","PSOPKIV1",175,0)
 I $P(PND0,"^",10)'=$P(TMP(1),"^",6) S ARET=-1,ARET("QTY PRESCRIBED")=$P(TMP(1),"^",6)_"^"_$P(PND0,"^",10)
"RTN","PSOPKIV1",176,0)
 ;I $P(PND0,"^",11)'=$P(TMP(1),"^",7) S ARET=-1,ARET("# OF REFILLS")=$P(TMP(1),"^",7)_"^"_$P(PND0,"^",11)
"RTN","PSOPKIV1",177,0)
 ;provider info
"RTN","PSOPKIV1",178,0)
 S INST=$P($G(^PS(52.41,PNP,"INI")),"^")
"RTN","PSOPKIV1",179,0)
 S DEA=$$DEA^XUSER(0,$P(PND0,"^",5))
"RTN","PSOPKIV1",180,0)
 I DEA'=$P(TMP(2),"^") S ARET=-1,ARET("DEA #")=$P(TMP(2),"^")_"^"_DEA
"RTN","PSOPKIV1",181,0)
 ;S DETOX=$$DETOX^XUSER($P(PND0,"^",5)) I DETOX'=$P(TMP(2),"^",2) S ARET=-1,ARET("DETOX #")=$P(TMP(2),"^",2)_"^"_DETOX
"RTN","PSOPKIV1",182,0)
 S NAM=$$GET1^DIQ(200,$P(PND0,"^",5),.01) I NAM'=$P(TMP(2),"^",3) S ARET=-1,ARET("PROVIDER NAME")=$P(TMP(2),"^",3)_"^"_NAM
"RTN","PSOPKIV1",183,0)
 ;patient inf
"RTN","PSOPKIV1",184,0)
 S DFN=$P(PND0,"^",2) D DEM^VADPT,ADD^VADPT
"RTN","PSOPKIV1",185,0)
 I VADM(1)'=$P(TMP(4),"^") S ARET=-1,ARET("PATIENT NAME")=$P(TMP(4),"^")_"^"_VADM(1)
"RTN","PSOPKIV1",186,0)
 I VAPA(1)'=$P(TMP(5),"^") S ARET=-1,ARET("PATIENT ADDRESS #1")=$P(TMP(5),"^")_"^"_VAPA(1)
"RTN","PSOPKIV1",187,0)
 I VAPA(2)'=$P(TMP(5),"^",2) S ARET=-1,ARET("PATIENT ADDRESS #2")=$P(TMP(5),"^",2)_"^"_VAPA(2)
"RTN","PSOPKIV1",188,0)
 I VAPA(3)'=$P(TMP(5),"^",3) S ARET=-1,ARET("PATIENT ADDRESS #3")=$P(TMP(5),"^",3)_"^"_VAPA(3)
"RTN","PSOPKIV1",189,0)
 I VAPA(4)'=$P(TMP(5),"^",4) S ARET=-1,ARET("PATIENT CITY")=$P(TMP(5),"^",4)_"^"_VAPA(4)
"RTN","PSOPKIV1",190,0)
 I $P(VAPA(5),"^",2)'=$P(TMP(5),"^",5) S ARET=-1,ARET("PATIENT STATE")=$P(TMP(5),"^",5)_"^"_$P(VAPA(5),"^",2)
"RTN","PSOPKIV1",191,0)
 I VAPA(6)'=$P(TMP(5),"^",6) S ARET=-1,ARET("PATIENT ZIP+4")=$P(TMP(5),"^",6)_"^"_VAPA(6)
"RTN","PSOPKIV1",192,0)
 ;sig
"RTN","PSOPKIV1",193,0)
 M ASIG=^TMP($J,"ORDEA",ORP,6)
"RTN","PSOPKIV1",194,0)
 S I=0 F  S I=$O(^PS(52.41,PNP,1,I)) Q:'I  D
"RTN","PSOPKIV1",195,0)
 .S INF0=$G(^PS(52.41,PNP,9,I,0)),INF1=$G(^PS(52.41,PNP,1,I,1))
"RTN","PSOPKIV1",196,0)
 .S PSIG(I)=INF0_"|"_$P(INF1,"^")_"|"_$P(INF1,"^",2)_"|"_$P(INF1,"^",6)_"|"_$P(INF1,"^",8)
"RTN","PSOPKIV1",197,0)
 S I=0 F  S I=$O(ASIG(I)) Q:'I  I ASIG(I)'=$G(PSIG(I)) S ND="SIG #"_I,ARET=-1 S ARET(ND)=ASIG(I)_"^"_$G(PSIG(I))
"RTN","PSOPKIV1",198,0)
 D KVA^VADPT
"RTN","PSOPKIV1",199,0)
 K ^TMP($J,"ORDEA")
"RTN","PSOPKIV1",200,0)
 Q $S($G(ARET):ARET,1:1)
"RTN","PSOPKIV1",201,0)
 ;
"RTN","PSOPKIV1",202,0)
ALERT ;
"RTN","PSOPKIV1",203,0)
 ; ORN=76 - Notification ID (ifn from OE/RR Notifications file  #100.9) 
"RTN","PSOPKIV1",204,0)
 ; ORBDFN=Patient DFN from Patient file #2 
"RTN","PSOPKIV1",205,0)
 ; ORNUM=Order ifn from Order file #100
"RTN","PSOPKIV1",206,0)
 ; ORBADUZ=Provider DUZ - Array of notification recipients requested by the calling package.  
"RTN","PSOPKIV1",207,0)
 ; ORBPMSG=Message text 
"RTN","PSOPKIV1",208,0)
 ; ORBPDATA=This is an identifier of the package entry which the notification is based on.  
"RTN","PSOPKIV1",209,0)
 ;          For radiology: Rad/Nuc Med exam/case ifn's(format: exam_ifn;case_ifn)
"RTN","PSOPKIV1",210,0)
 ;          For consults:  the IEN of the consult in file 123 
"RTN","PSOPKIV1",211,0)
 N PSOX S PSOX=1
"RTN","PSOPKIV1",212,0)
 S PSOX(+$P(OR0,"^",5))=""
"RTN","PSOPKIV1",213,0)
 D EN^ORB3(76,PSODFN,$P(OR0,"^"),.PSOX,"DEA certificate expired. Renew your certificate.","")
"RTN","PSOPKIV1",214,0)
 Q
"RTN","PSOPKIV1",215,0)
 ; 
"RTN","PSOPKIV1",216,0)
00 ;;Order Text is blank;;
"RTN","PSOPKIV1",217,0)
01 ;;DEA # missing;;
"RTN","PSOPKIV1",218,0)
02 ;;Drug Schedule missing;;
"RTN","PSOPKIV1",219,0)
03 ;;DEA # not valid;;
"RTN","PSOPKIV1",220,0)
04 ;;Valid Certificate not found;;
"RTN","PSOPKIV1",221,0)
05 ;;Couldn't load CSP;;
"RTN","PSOPKIV1",222,0)
06 ;;Smart card Reader not found;;
"RTN","PSOPKIV1",223,0)
07 ;;Certificate with DEA # not found;;
"RTN","PSOPKIV1",224,0)
08 ;;Certificate not valid for schedule;;
"RTN","PSOPKIV1",225,0)
10 ;;Crypto Error (contact IRM);;
"RTN","PSOPKIV1",226,0)
15 ;;Corrupted (Decode failure);;
"RTN","PSOPKIV1",227,0)
16 ;;Corrupted (Hash mismatch);;
"RTN","PSOPKIV1",228,0)
17 ;;Certificate revoked;;
"RTN","PSOPKIV1",229,0)
18 ;;Verification failure;;
"RTN","PSOPKIV1",230,0)
19 ;;Before Cert effective date;;
"RTN","PSOPKIV1",231,0)
20 ;;Certificate expired;;
"RTN","PSOPKIV1",232,0)
21 ;;No Cert with a valid date found;;
"RTN","PSOPKIV1",233,0)
22 ;;Signature Check failed (Invalid Signature);;
"RTN","PSOPKIV1",234,0)
23 ;;CERT_IS_NOT_TIME_NESTED;;
"RTN","PSOPKIV1",235,0)
24 ;;CERT_IS_NOT_VALID_FOR_USAGE;;
"RTN","PSOPKIV1",236,0)
25 ;;CERT_IS_UNTRUSTED_ROOT;;
"RTN","PSOPKIV1",237,0)
26 ;;CERT_REVOCATION_STATUS_UNKNOWN;;
"RTN","PSOPKIV1",238,0)
27 ;;CERT_IS_CYCLIC;;
"RTN","PSOPKIV1",239,0)
28 ;;CERT_IS_PARTIAL_CHAIN;;
"RTN","PSOPKIV1",240,0)
29 ;;CERT_CTL_IS_NOT_SIGNATURE_VALID;;
"RTN","PSOPKIV1",241,0)
30 ;;CERT_CTL_IS_NOT_VALID_FOR_USAGE;;
"RTN","PSOPKIV2")
0^28^B23465178^n/a
"RTN","PSOPKIV2",1,0)
PSOPKIV2 ;BIR/MHA - Dig Signed Pending order Auto-DC message ;08/17/11
"RTN","PSOPKIV2",2,0)
 ;;7.0;OUTPATIENT PHARMACY;**391**;DEC 1997;Build 13
"RTN","PSOPKIV2",3,0)
 ;
"RTN","PSOPKIV2",4,0)
ADCMAIL ;
"RTN","PSOPKIV2",5,0)
 N XX,QQ,ZZ S ZZ="PSOPODC"
"RTN","PSOPKIV2",6,0)
 K ^TMP(ZZ,$J)
"RTN","PSOPKIV2",7,0)
 S XMSUB=$P(^PS(59,PSOSITE,0),"^",6)_" - DIGITALLY SIGNED "_$S($P(OR0,"^",3)="RNW":"RE",1:"")_"NEW ORDER AUTO DISCONTINUED",XMDUZ=.5
"RTN","PSOPKIV2",8,0)
 S LC=1,^TMP(ZZ,$J,LC)="",LC=LC+1
"RTN","PSOPKIV2",9,0)
 S ^TMP(ZZ,$J,LC)="Following order was auto discontinued when finishing a pending order due to "_$P(PKIE,": ",2),LC=LC+1
"RTN","PSOPKIV2",10,0)
 S ^TMP(ZZ,$J,LC)="",LC=LC+1
"RTN","PSOPKIV2",11,0)
 S ^TMP(ZZ,$J,LC)="Division      : "_$P(^PS(59,PSOSITE,0),"^"),LC=LC+1
"RTN","PSOPKIV2",12,0)
 S ^TMP(ZZ,$J,LC)="CPRS Order #  : "_$P(OR0,"^"),LC=LC+1
"RTN","PSOPKIV2",13,0)
 S ^TMP(ZZ,$J,LC)="Issue Date    : "_PSONEW("ISSUE DATE"),LC=LC+1
"RTN","PSOPKIV2",14,0)
 S ^TMP(ZZ,$J,LC)="Patient       : "_$P(^DPT(DFN,0),U)_" ("_$G(VA("BID"))_")",LC=LC+1
"RTN","PSOPKIV2",15,0)
 ;S ^TMP(ZZ,$J,LC)="Address       : ",LC=LC+1
"RTN","PSOPKIV2",16,0)
 D PATAD
"RTN","PSOPKIV2",17,0)
 S ^TMP(ZZ,$J,LC)="Drug          : "_$G(PSODRUG("NAME")),LC=LC+1
"RTN","PSOPKIV2",18,0)
 S QQ=PSONEW("DOSE",1) S:PSONEW("UNITS",1) QQ=QQ_"("_$P(^PS(50.607,PSONEW("UNITS",1),0),"^")_")"
"RTN","PSOPKIV2",19,0)
 I $O(PSONEW("DOSE",1)) S XX=1 F  S XX=$O(PSONEW("DOSE",XX)) Q:'XX  D
"RTN","PSOPKIV2",20,0)
 .S QQ=QQ_","_PSONEW("DOSE",XX)
"RTN","PSOPKIV2",21,0)
 .S:PSONEW("UNITS",XX) QQ=QQ_"("_$P(^PS(50.607,PSONEW("UNITS",XX),0),"^")_")"
"RTN","PSOPKIV2",22,0)
 S ^TMP(ZZ,$J,LC)="Dosage Ordered: "_QQ
"RTN","PSOPKIV2",23,0)
 S LC=LC+1
"RTN","PSOPKIV2",24,0)
 S ^TMP(ZZ,$J,LC)="Dosage Form   : "_PSONEW("NOUN",1),LC=LC+1
"RTN","PSOPKIV2",25,0)
 S ^TMP(ZZ,$J,LC)="Quantity      : "_PSONEW("QTY")
"RTN","PSOPKIV2",26,0)
 N TLC K TMP("ZZ") S XX=0,TLC=1,TMP("ZZ",1,0)="SIG           : "
"RTN","PSOPKIV2",27,0)
 F  S XX=$O(^PS(52.41,ORD,"SIG",XX)) Q:'XX  D
"RTN","PSOPKIV2",28,0)
 .S QQ=^PS(52.41,ORD,"SIG",XX,0)
"RTN","PSOPKIV2",29,0)
 .D WORDWRAP^PSOUTLA2(QQ,.TLC,$NA(TMP("ZZ")),15)
"RTN","PSOPKIV2",30,0)
 S XX=0 F  S XX=$O(TMP("ZZ",XX)) Q:'XX  S ^TMP(ZZ,$J,LC+1)=TMP("ZZ",XX,0)
"RTN","PSOPKIV2",31,0)
 S LC=LC+1
"RTN","PSOPKIV2",32,0)
 S ^TMP(ZZ,$J,LC)="Provider      : "_PSONEW("PROVIDER NAME"),LC=LC+1
"RTN","PSOPKIV2",33,0)
 D PRV
"RTN","PSOPKIV2",34,0)
 S LC=LC+1,^TMP(ZZ,$J,LC)=""
"RTN","PSOPKIV2",35,0)
 I $G(PKIOR)=16 D MISMCH
"RTN","PSOPKIV2",36,0)
 D MGRP
"RTN","PSOPKIV2",37,0)
 S XMY(DUZ)="",XMTEXT="^TMP(ZZ,$J," N DIFROM D ^XMD K XMDUZ,XMTEXT,XMSUB
"RTN","PSOPKIV2",38,0)
 K ^TMP(ZZ,$J)
"RTN","PSOPKIV2",39,0)
 Q
"RTN","PSOPKIV2",40,0)
 ;
"RTN","PSOPKIV2",41,0)
MISMCH ;Reason for mis-match
"RTN","PSOPKIV2",42,0)
 N XX,XY,XZ,X1,X2,XM,PSOARY,HASH
"RTN","PSOPKIV2",43,0)
 S HASH=$$HSHCHK^PSOPKIV1(.PSOARY,ORD) I HASH'=-1 Q
"RTN","PSOPKIV2",44,0)
 I $O(PSOARY(""))="" Q
"RTN","PSOPKIV2",45,0)
 ;I $G(PSOARY)'=-1 Q
"RTN","PSOPKIV2",46,0)
 S $P(XZ," ",80)="",LC=LC+1
"RTN","PSOPKIV2",47,0)
 S ^TMP(ZZ,$J,LC)="Differences in CPRS and Pharmacy Pending File",LC=LC+1,^TMP(ZZ,$J,LC)=""
"RTN","PSOPKIV2",48,0)
 S LC=LC+1,^TMP(ZZ,$J,LC)="Data Name          CPRS File                    Pharmacy Pending File"
"RTN","PSOPKIV2",49,0)
 S LC=LC+1,^TMP(ZZ,$J,LC)="---------          ---------                    ---------------------"
"RTN","PSOPKIV2",50,0)
 S LC=LC+1,XX=""
"RTN","PSOPKIV2",51,0)
 F  S XX=$O(PSOARY(XX)) Q:XX=""  D
"RTN","PSOPKIV2",52,0)
 .S XY=PSOARY(XX),LC=LC+1
"RTN","PSOPKIV2",53,0)
 .S X1=$P(XY,"^"),X2=$P(XY,"^",2)
"RTN","PSOPKIV2",54,0)
 .S XM=$S($L(X1)>$L(X2):X1,1:X2),STR=""
"RTN","PSOPKIV2",55,0)
 .F I=0:1:$L(XM) Q:$E(XM,28*I,$L(XM))=""  S ^TMP(ZZ,$J,LC)=$S(I=0:$E(XX,1,18),1:"")_$$BLNK(19,$S(I=0:$E(XX,1,18),1:""))_$E(X1,(28*I),(28*I+28))_$$BLNK(29,$S($E(X1,(28*I),(28*I+28))]"":$E(X1,(28*I),(28*I+28)),1:""))_$E(X2,(28*I),(28*I+28)),LC=LC+1
"RTN","PSOPKIV2",56,0)
 Q
"RTN","PSOPKIV2",57,0)
 ;
"RTN","PSOPKIV2",58,0)
BLNK(X,STR) ;blank spaces
"RTN","PSOPKIV2",59,0)
 N XZ,SP
"RTN","PSOPKIV2",60,0)
 Q:X="" ""
"RTN","PSOPKIV2",61,0)
 S $P(XZ," ",80)="",SP=X-$L(STR)
"RTN","PSOPKIV2",62,0)
 Q $E(XZ,1,SP)
"RTN","PSOPKIV2",63,0)
MGRP ;
"RTN","PSOPKIV2",64,0)
 N MDUZ S MDUZ=0 F  S MDUZ=$O(^XUSEC("PSDMGR",MDUZ)) Q:MDUZ'>0  S XMY(MDUZ)=""
"RTN","PSOPKIV2",65,0)
 Q
"RTN","PSOPKIV2",66,0)
 ;
"RTN","PSOPKIV2",67,0)
PRV ;
"RTN","PSOPKIV2",68,0)
 N DEA,VADD,PRV,DRG,ORN
"RTN","PSOPKIV2",69,0)
 S PRV=$G(PSONEW("PROVIDER")),DRG=$G(PSODRUG("IEN")),ORN=$P(OR0,"^")
"RTN","PSOPKIV2",70,0)
 I PRV="" Q
"RTN","PSOPKIV2",71,0)
 S DEA=$$DEA^XUSER(0,PRV)
"RTN","PSOPKIV2",72,0)
 S DEA=$S(DEA["-":"VA#           : ",1:"DEA#          : ")_DEA
"RTN","PSOPKIV2",73,0)
 S ^TMP(ZZ,$J,LC)=DEA
"RTN","PSOPKIV2",74,0)
 I $$DETOX^PSSOPKI(DRG),$$DETOX^XUSER(PRV)'="" S ^TMP(ZZ,$J,LC)=^TMP(ZZ,$J,LC)_"  DETOX#: "_$$DETOX^XUSER(PRV)
"RTN","PSOPKIV2",75,0)
 D PRVAD
"RTN","PSOPKIV2",76,0)
 I $G(VADD(1))]"" D
"RTN","PSOPKIV2",77,0)
 .S LC=LC+1,^TMP(ZZ,$J,LC)="Site Address  : "_VADD(1)
"RTN","PSOPKIV2",78,0)
 .S:VADD(2)'="" LC=LC+1,^TMP(ZZ,$J,LC)="                "_VADD(2)
"RTN","PSOPKIV2",79,0)
 .S:VADD(3)'="" LC=LC+1,^TMP(ZZ,$J,LC)="                "_VADD(3)
"RTN","PSOPKIV2",80,0)
 Q
"RTN","PSOPKIV2",81,0)
 ;
"RTN","PSOPKIV2",82,0)
PRVAD ;
"RTN","PSOPKIV2",83,0)
 K ^TMP($J,"ORDEA")
"RTN","PSOPKIV2",84,0)
 D ARCHIVE^ORDEA(ORN)
"RTN","PSOPKIV2",85,0)
 I $D(^TMP($J,"ORDEA",ORN,3)) S VADD=^(3) D
"RTN","PSOPKIV2",86,0)
 .S VADD(1)=$P(VADD,"^",2),VADD(2)=$P(VADD,"^",3),VADD(3)=$P(VADD,"^",4)_", "_$P(VADD,"^",5)_" "_$P($P(VADD,"^",6),"-")
"RTN","PSOPKIV2",87,0)
 K ^TMP($J,"ORDEA")
"RTN","PSOPKIV2",88,0)
 Q
"RTN","PSOPKIV2",89,0)
 ;
"RTN","PSOPKIV2",90,0)
PATAD ;
"RTN","PSOPKIV2",91,0)
 D ^VADPT,ADD^VADPT
"RTN","PSOPKIV2",92,0)
 N PSOBADR,PSOTEMP,PSOFORGN,I,T
"RTN","PSOPKIV2",93,0)
 S PSOBADR=0,PSOTEMP=0,XX=0
"RTN","PSOPKIV2",94,0)
 S PSOFORGN=$P($G(VAPA(25)),"^",2) I PSOFORGN'="",PSOFORGN'["UNITED STATES" S PSOFORGN=1
"RTN","PSOPKIV2",95,0)
 I 'PSOFORGN S PSOBADR=$$BADADR^DGUTL3(DFN)
"RTN","PSOPKIV2",96,0)
 I 'PSOFORGN,PSOBADR S PSOTEMP=$$CHKTEMP^PSOBAI(DFN)
"RTN","PSOPKIV2",97,0)
 F I=1:1:3 I $G(VAPA(I))]"" D
"RTN","PSOPKIV2",98,0)
 . S T="" I I=1,'PSOFORGN,PSOBADR,'$G(PSOTEMP) S T="** BAD ADDRESS INDICATED **"
"RTN","PSOPKIV2",99,0)
 . I I=1,T="",PSOFORGN S T="*** FOREIGN ADDRESS ***"
"RTN","PSOPKIV2",100,0)
 . I T="" I 'PSOFORGN I 'PSOBADR!$G(PSOTEMP) S T=$G(VAPA(I))
"RTN","PSOPKIV2",101,0)
 . I I=1,T]"" S ^TMP(ZZ,$J,LC)="Address       : "_T,LC=LC+1
"RTN","PSOPKIV2",102,0)
 . I I>1,T]"" S ^TMP(ZZ,$J,LC)="                "_T,LC=LC+1
"RTN","PSOPKIV2",103,0)
 S I=+$G(VAPA(5)) I I S I=$S($D(^DIC(5,I,0)):$P(^(0),"^",2),1:"UNKNOWN")
"RTN","PSOPKIV2",104,0)
 S T="" I 'PSOFORGN I 'PSOBADR!$G(PSOTEMP) S T=$G(VAPA(4))_", "_I_"  "_$S($G(VAPA(11)):$P(VAPA(11),"^",2),1:$G(VAPA(6)))
"RTN","PSOPKIV2",105,0)
 S:T]"" ^TMP(ZZ,$J,LC)="                "_T,LC=LC+1
"RTN","PSOPKIV2",106,0)
 Q
"RTN","PSOPKIV2",107,0)
 ;
"RTN","PSOPRVW")
0^34^B40061242^B37841346
"RTN","PSOPRVW",1,0)
PSOPRVW ;BIR/SAB,MHA-enter/edit/view provider ; 2/9/07 10:39am
"RTN","PSOPRVW",2,0)
 ;;7.0;OUTPATIENT PHARMACY;**11,146,153,263,268,264,398,391**;DEC 1997;Build 13
"RTN","PSOPRVW",3,0)
 ;
"RTN","PSOPRVW",4,0)
 ;Ref. to ^VA(200 supp. by IA 224
"RTN","PSOPRVW",5,0)
 ;Ref. to ^DIC(7 supp. by IA 491
"RTN","PSOPRVW",6,0)
 ;Ref.  to $$NPI^XUSNPI supp. by IA 4532
"RTN","PSOPRVW",7,0)
 ;
"RTN","PSOPRVW",8,0)
START W ! S DIC("A")="Select Provider: ",DIC("S")="I $D(^VA(200,+Y,""PS""))",DIC="^VA(200,",DIC(0)="AEQMZ" D ^DIC G:"^"[X EX G:Y<0 START K DIC S PRNO=+Y
"RTN","PSOPRVW",9,0)
 W @IOF,"Name: "_$P(^VA(200,PRNO,0),"^")
"RTN","PSOPRVW",10,0)
 I +$P(^VA(200,PRNO,"PS"),"^",4),$P(^("PS"),"^",4)'>DT W ?40,$C(7),"* * * INACTIVE AS OF ",$E($P(^("PS"),"^",4),4,5),"/",$E($P(^("PS"),"^",4),6,7),"/",$E($P(^("PS"),"^",4),2,3)," * * *"
"RTN","PSOPRVW",11,0)
 ;W !,"SSN#: " S T=$S($P(^VA(200,PRNO,1),"^",9)]"":$P(^(1),"^",9),1:"") W:T $E(T,1,3),"-",$E(T,4,5),"-",$E(T,6,9)
"RTN","PSOPRVW",12,0)
 W !,"Initials: "_$P(^VA(200,PRNO,0),"^",2)
"RTN","PSOPRVW",13,0)
 W !,"NON-VA Prescriber: "
"RTN","PSOPRVW",14,0)
 I $P($G(^VA(200,PRNO,"TPB")),"^")]"" W $S($P(^("TPB"),"^"):"Yes",1:"No")
"RTN","PSOPRVW",15,0)
 W ?40,"Tax ID: "_$P($G(^VA(200,PRNO,"TPB")),"^",2)
"RTN","PSOPRVW",16,0)
 W !,"Exclusionary Check Performed: " I $P($G(^VA(200,PRNO,"TPB")),"^",3)]"" W $S($P(^("TPB"),"^",3):"Yes",1:"No")
"RTN","PSOPRVW",17,0)
 W ?40,"Date Exclusionary List Checked: "
"RTN","PSOPRVW",18,0)
 S Y=$P($G(^VA(200,PRNO,"TPB")),"^",4) I Y W $E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)
"RTN","PSOPRVW",19,0)
 W !,"On Exclusionary List: " I $P($G(^VA(200,PRNO,"TPB")),"^",5)]"" W $S($P(^("TPB"),"^",5):"Yes",1:"No")
"RTN","PSOPRVW",20,0)
 W !,"Exclusionary Checked By: "
"RTN","PSOPRVW",21,0)
 I $P($G(^VA(200,PRNO,"TPB")),"^",6) W $P($G(^VA(200,$P(^("TPB"),"^",6),0)),"^")
"RTN","PSOPRVW",22,0)
 W !,"Authorized to Write Orders: "_$S($P(^VA(200,PRNO,"PS"),"^"):"Yes",1:"No")
"RTN","PSOPRVW",23,0)
 W !,"Requires Cosigner: "_$S($P(^("PS"),"^",7):"Yes",1:"No"),?40,"DEA#: "_$P(^VA(200,PRNO,"PS"),"^",2) I $P(^("PS"),"^",7),$D(^VA(200,+$P(^("PS"),"^",8),0)) W !,"Usual Cosigner: "_$P(^(0),"^")
"RTN","PSOPRVW",24,0)
 W !,"Detox/Maintenance ID#: "_$P(^VA(200,PRNO,"PS"),"^",11)
"RTN","PSOPRVW",25,0)
 I $P($G(^VA(200,PRNO,"PS")),"^",2)]"" W ?40,"DEA Expiration Date: " S T=+$P($G(^VA(200,PRNO,"QAR")),"^",9) I T W $$FMTE^XLFDT(T)
"RTN","PSOPRVW",26,0)
 W !,"Class: " S PRCLS=+$P(^VA(200,PRNO,"PS"),"^",5),PRCLS=$S(PRCLS>0&$D(^DIC(7,PRCLS,0)):$P(^(0),"^"),1:"") W PRCLS,?40,"VA#:  "_$P(^VA(200,PRNO,"PS"),"^",3)
"RTN","PSOPRVW",27,0)
 W !," Type: " S T=+$P(^("PS"),"^",6),L=$P(^DD(200,53.6,0),"^",3)_";"_T_":Unknown" F I=1:1 I $P($P(L,";",I),":",1)=T W $P($P(L,";",I),":",2) Q
"RTN","PSOPRVW",28,0)
 N NPI S NPI=$P($$NPI^XUSNPI("Individual_ID",PRNO),"^") W ?40,"NPI#: "_$S(NPI>0:+NPI,1:"")
"RTN","PSOPRVW",29,0)
 W !,"Remarks: "_$P(^VA(200,PRNO,"PS"),"^",9),!,"Synonym(s):  "_$S($P($G(^VA(200,PRNO,.1)),"^",4)]"":$P(^(.1),"^",4)_",",1:"")_$S($P(^(0),"^",2)]"":" "_$P(^(0),"^",2),1:"")
"RTN","PSOPRVW",30,0)
 W !,"Service/Section: " S PSOSSDA=$G(DA) I $P($G(^VA(200,PRNO,5)),"^") K DIQ S DIC="^DIC(49,",DA=$P(^VA(200,PRNO,5),"^"),DR=.01,DIQ="PSOSECT",DIQ(0)="E" D EN^DIQ1 W $G(PSOSECT(49,DA,.01,"E")) S DA=$G(PSOSSDA) K DR,DIC,DIQ,PSOSSDA,PSOSECT
"RTN","PSOPRVW",31,0)
 I $TR($G(^VA(200,PRNO,.11)),"^","")="" G NUM
"RTN","PSOPRVW",32,0)
 W !!,"Address: ",?10,$P(^VA(200,PRNO,.11),"^") W:$P(^(.11),"^",2)'="" !?10,$P(^(.11),"^",2) W:$P(^(.11),"^",3)'="" !?10,$P(^(.11),"^",3)
"RTN","PSOPRVW",33,0)
 W !?10,$P(^VA(200,PRNO,.11),"^",4) W:$P(^(.11),"^",4)]"" ", " S STAT=+$P($G(^(.11)),"^",5) W $S($D(^DIC(5,STAT,0)):$P(^(0),"^"),1:"")_"  "_$P(^VA(200,PRNO,.11),"^",6)
"RTN","PSOPRVW",34,0)
NUM G:'$D(^VA(200,PRNO,.13)) START
"RTN","PSOPRVW",35,0)
 W !,"Phone:    "_$P(^VA(200,PRNO,.13),"^"),! W:$P(^(.13),"^",2)]"" "Office:   ",$P(^(.13),"^",2),!
"RTN","PSOPRVW",36,0)
 W:$P(^VA(200,PRNO,.13),"^",3)]"" "Phone #3: "_$P(^(.13),"^",3),?40 W:$P(^(.13),"^",7)]"" "Voice Pager  #: "_$P(^(.13),"^",7) W !
"RTN","PSOPRVW",37,0)
 W:$P(^VA(200,PRNO,.13),"^",4)]"" "Phone #4: "_$P(^(.13),"^",4),?40 W:$P(^(.13),"^",8)]"" "Digital Pager#: "_$P(^(.13),"^",8)
"RTN","PSOPRVW",38,0)
 W:$P(^VA(200,PRNO,.13),"^",6)]"" !,"Fax #:    "_$P(^(.13),"^",6)
"RTN","PSOPRVW",39,0)
 W:$P($G(^VA(200,PRNO,.14)),"^")]"" !,"Room Loc: "_$P(^(.14),"^")
"RTN","PSOPRVW",40,0)
 G START
"RTN","PSOPRVW",41,0)
EX K DIC,DIE,DA,DR,D0,PRNO,PRCLS,STAT,T,Y,X,L,LF,I,DIR,DIROUT,DUOUT,DTOUT,DIRUT,%,%Y,%W,%Z,C,DDH,DI,DIH,DLAYGO,DQ,X1,XMDT,XMN
"RTN","PSOPRVW",42,0)
 Q
"RTN","PSOPRVW",43,0)
ASK ;edit providers
"RTN","PSOPRVW",44,0)
 K DIR,DTOUT,DUOUT,DIROUT,DIRUT
"RTN","PSOPRVW",45,0)
 W !! S DIC("A")="Select Provider: ",(DIC,DIE)=200,DIC(0)="AEQMZ" D ^DIC G:"^"[X EX G:Y<0 ASK S (FADA,DA)=+Y
"RTN","PSOPRVW",46,0)
 I '$D(^VA(200,DA,"PS")) G NPRV
"RTN","PSOPRVW",47,0)
ASK1 W @IOF,?25,"Provider: "_$P(^VA(200,DA,0),"^"),! F DR="TPB","PS","QAR",".11",".13",".14" D EN^DIQ
"RTN","PSOPRVW",48,0)
 K DIC,Y
"RTN","PSOPRVW",49,0)
EDT W ! L +^VA(200,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
"RTN","PSOPRVW",50,0)
 I '$T W $C(7),!!,"Provider Data is Being Edited by Another User!",! G QX
"RTN","PSOPRVW",51,0)
 N RTPB S RTPB=$G(^VA(200,DA,"TPB"))
"RTN","PSOPRVW",52,0)
 S DR="53.91" D ^DIE I $D(Y)!$D(DTOUT) G QX
"RTN","PSOPRVW",53,0)
 I 'X,$G(PSOTPBFG) G QX
"RTN","PSOPRVW",54,0)
 I X S DR="53.92R;53.93R;53.94R;53.95R"
"RTN","PSOPRVW",55,0)
 E  S DR="53.92;53.93;53.94;53.95"
"RTN","PSOPRVW",56,0)
 S DR=DR_";D:X MS^PSOPRVW",DIE("NO^")="OUTOK" D ^DIE K DIE("NO^")
"RTN","PSOPRVW",57,0)
 I '$D(^VA(200,DA,"TPB")),$G(PSOTPBFG) G QX
"RTN","PSOPRVW",58,0)
 I $D(Y)!$D(DTOUT) D:$P($G(^VA(200,DA,"TPB")),"^",3)  G QX
"RTN","PSOPRVW",59,0)
 .I RTPB=""!('$P(RTPB,"^",3)) S DR="53.96////"_DUZ D ^DIE
"RTN","PSOPRVW",60,0)
 I $P($G(^VA(200,DA,"TPB")),"^",3) D
"RTN","PSOPRVW",61,0)
 .I RTPB=""!('$P(RTPB,"^",3)) S DR="53.96////"_DUZ D ^DIE
"RTN","PSOPRVW",62,0)
 N PSORTPB S PSORTPB=$G(^VA(200,DA,"TPB"))
"RTN","PSOPRVW",63,0)
 I $P(PSORTPB,"^",4)'=$P(RTPB,"^",4)!($P(PSORTPB,"^",5)'=$P(RTPB,"^",5)) D
"RTN","PSOPRVW",64,0)
 .S DR="53.96////"_DUZ D ^DIE
"RTN","PSOPRVW",65,0)
 G:$G(PSOTPBFG) QX
"RTN","PSOPRVW",66,0)
ED1 S DR="53.1;53.2;53.11;53.3:53.6;I X'=4 S Y=""@1"";747.44;29;8932.1;@1;53.7;I 'X S Y=""@2"";53.8;@2;53.9;.111:.116;.131:.134;.136;.137;.138;.141",DR(2,200.05)=".01;2;3"
"RTN","PSOPRVW",67,0)
 D ^DIE S FADA=DA D:'$D(Y) KEY
"RTN","PSOPRVW",68,0)
QX K FADA,RTPB,PSORTPB L -^VA(200,DA) Q:$G(PSOTPBFG)  G:+$G(VADA) ADD G ASK
"RTN","PSOPRVW",69,0)
 Q
"RTN","PSOPRVW",70,0)
 G:'$D(^VA(200,DA,"TPB")) ED1
"RTN","PSOPRVW",71,0)
ADD ;add new providers (kernel 7)
"RTN","PSOPRVW",72,0)
 W !
"RTN","PSOPRVW",73,0)
 S VADA=$$ADD^XUSERNEW("53.91;S:'X Y=""@2"";53.92R;53.93R;53.94R;53.95R;D:X MS^PSOPRVW;@2;53.1;53.2;53.3;53.4;53.5;53.6;S:X'=4 Y=""@4"";747.44;@4;53.7;S:'X Y=""@1"";53.8;@1;53.9;.111:.116;.131:.134;.136;.141")
"RTN","PSOPRVW",74,0)
 S (FADA,DA)=+VADA,(DIC,DIE)="^VA(200,"
"RTN","PSOPRVW",75,0)
 I VADA>0,$P(VADA,"^",3),$P($G(^VA(200,DA,"TPB")),"^") D
"RTN","PSOPRVW",76,0)
 .S DR="53.96////"_DUZ D ^DIE
"RTN","PSOPRVW",77,0)
 I VADA>0,'$P(VADA,"^",3) S DIC(0)="AEQMZ" G:'$D(^VA(200,+VADA,"PS")) NPRV G:$D(^VA(200,+VADA,"PS")) ASK1
"RTN","PSOPRVW",78,0)
 D:VADA>0 KEY K DIK,DIC,Y,X,VADA,VA,DEA Q:$G(PSOTPBFG)  K DA G EX
"RTN","PSOPRVW",79,0)
 Q
"RTN","PSOPRVW",80,0)
NPRV W ! S DIR("A",1)=$P(^VA(200,DA,0),"^")_" is NOT currently indicated as being a provider.",DIR("A")="Do you want to make "_$P(^VA(200,DA,0),"^")_" a provider? (Y/N): ",DIR(0)="SA^1:YES;0:NO",DIR("B")="NO"
"RTN","PSOPRVW",81,0)
 S DIR("?",1)="Answer with '1' or 'Yes' if "_$P(^VA(200,DA,0),"^")_" is to become a provider",DIR("?")="otherwise press return for 'No' and re-enter name." D ^DIR G:$D(DTOUT) EX
"RTN","PSOPRVW",82,0)
 G:'Y!($D(DIRUT))&('+$G(VADA)) ASK G:'$P(+$G(VADA),"^",3)&('Y) ADD
"RTN","PSOPRVW",83,0)
 G EDT
"RTN","PSOPRVW",84,0)
 Q
"RTN","PSOPRVW",85,0)
KEY I $D(^VA(200,DA,"PS")) D
"RTN","PSOPRVW",86,0)
 .I '$P(^VA(200,DA,"PS"),"^",4)!($P(^("PS"),"^",4)>DT) S PSOPDA=DA K DIC S DIC="^DIC(19.1,",DIC(0)="MZ",X="PROVIDER" D ^DIC K DIC S DA=PSOPDA K PSOPDA I +Y>0 S X=+Y D
"RTN","PSOPRVW",87,0)
 ..S:'$D(^VA(200,FADA,51,0)) ^VA(200,FADA,51,0)="^"_$P(^DD(200,51,0),"^",2)_"^^"
"RTN","PSOPRVW",88,0)
 ..S DIC="^VA(200,"_FADA_",51,",DIC(0)="LM",DIC("DR")="1////"_$S($G(DUZ):DUZ,1:"")_";2///"_DT,DLAYGO=200.051,DINUM=X,DA(1)=FADA
"RTN","PSOPRVW",89,0)
 ..L +^VA(200,FADA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) K DD,DO D FILE^DICN L -^VA(200,FADA) K DIC,DR,X,Y
"RTN","PSOPRVW",90,0)
 Q
"RTN","PSOPRVW",91,0)
MS ;
"RTN","PSOPRVW",92,0)
 W !!,$C(7),"This provider will not be selectable during TPB medication order entry!!",!
"RTN","PSOPRVW",93,0)
 Q
"RTN","PSORN52C")
0^44^B68196793^B50785936
"RTN","PSORN52C",1,0)
PSORN52C ;BIR/SAB-files renewal entries con't ;08/09/93
"RTN","PSORN52C",2,0)
 ;;7.0;OUTPATIENT PHARMACY;**1,7,11,27,46,75,87,100,111,124,117,131,146,148,200,225,251,387,379,391**;DEC 1997;Build 13
"RTN","PSORN52C",3,0)
 ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
"RTN","PSORN52C",4,0)
 S DIC="^PSRX(",DLAYGO=52,DIC(0)="L",X=PSOX("NRX #") K DD,DO
"RTN","PSORN52C",5,0)
 D FILE^DICN S PSOX("IRXN")=+Y K DLAYGO,X,Y,DIC,DD,DO
"RTN","PSORN52C",6,0)
 D:+$G(DGI) TECH^PSODGDGP ; L +^PSRX(PSOX("IRXN")):0
"RTN","PSORN52C",7,0)
 D:$G(^TMP("PSODAI",$J,0))
"RTN","PSORN52C",8,0)
 .S $P(^PSRX(PSOX("IRXN"),3),"^",6)=1
"RTN","PSORN52C",9,0)
 .I $O(^TMP("PSODAI",$J,0)) S DAI=0 F  S DAI=$O(^TMP("PSODAI",$J,DAI)) Q:'DAI  D
"RTN","PSORN52C",10,0)
 ..S:'$D(^PSRX(PSOX("IRXN"),"DAI",0)) ^PSRX(PSOX("IRXN"),"DAI",0)="^52.03^^" S ^PSRX(PSOX("IRXN"),"DAI",DAI,0)=^TMP("PSODAI",$J,DAI,0)
"RTN","PSORN52C",11,0)
 ..S $P(^PSRX(PSOX("IRXN"),"DAI",0),"^",3)=+$P(^PSRX(PSOX("IRXN"),"DAI",0),"^",3)+1,$P(^(0),"^",4)=+$P(^(0),"^",4)+1
"RTN","PSORN52C",12,0)
 .K ^TMP("PSODAI",$J),DAI
"RTN","PSORN52C",13,0)
 S PSORN52(PSOX("IRXN"),0)=PSOX("NRX0"),PSORN52(PSOX("IRXN"),2)=PSOX("NRX2"),PSORN52(PSOX("IRXN"),3)=PSOX("NRX3")
"RTN","PSORN52C",14,0)
 S PSORN52(PSOX("IRXN"),"EPH")=PSOX("EPH")
"RTN","PSORN52C",15,0)
 S:'$G(PSOX("ENT")) PSORN52(PSOX("IRXN"),"SIG")=PSOX("SIG")
"RTN","PSORN52C",16,0)
 I '$D(^XUSEC("PSORPH",DUZ)),$$DS^PSSDSAPI&(+$G(^TMP("PSODOSF",$J,0))) S PSOX("STA")=1
"RTN","PSORN52C",17,0)
 S PSORN52(PSOX("IRXN"),"STA")=PSOX("STA")
"RTN","PSORN52C",18,0)
 S:$G(PSOX("TN"))]"" PSORN52(PSOX("IRXN"),"TN")=PSOX("TN")
"RTN","PSORN52C",19,0)
 I $G(PSOX("METHOD OF PICK-UP"))]"",PSOX("FILL DATE")'>DT S PSORN52(PSOX("IRXN"),"MP")=PSOX("METHOD OF PICK-UP")
"RTN","PSORN52C",20,0)
 S PSORN52(PSOX("IRXN"),"TYPE")=0
"RTN","PSORN52C",21,0)
 S PSOX1="" F  S PSOX1=$O(PSORN52(PSOX("IRXN"),PSOX1)) Q:PSOX1=""  S ^PSRX(PSOX("IRXN"),PSOX1)=$G(PSORN52(PSOX("IRXN"),PSOX1))
"RTN","PSORN52C",22,0)
 I $O(SIG(0)) D  G ENT
"RTN","PSORN52C",23,0)
 .S II=0 F I=0:0 S I=$O(SIG(I)) Q:'I  S ^PSRX(PSOX("IRXN"),"SIG1",I,0)=SIG(I),II=II+1
"RTN","PSORN52C",24,0)
 .S ^PSRX(PSOX("IRXN"),"SIG1",0)="^52.04A^"_II_"^"_II,$P(^PSRX(PSOX("IRXN"),"SIG"),"^",2)=1 K I,II
"RTN","PSORN52C",25,0)
 .S $P(^PSRX(PSOX("IRXN"),"SIG"),"^",2)=1
"RTN","PSORN52C",26,0)
ENT S ^PSRX(PSOX("IRXN"),"POE")=1,^PSRX(PSOX("IRXN"),"INS")=$G(PSOX("INS"))
"RTN","PSORN52C",27,0)
 I $G(OR0),$P(OR0,"^",24) S ^PSRX(PSOX("IRXN"),"PKI")=1 D ACLOG
"RTN","PSORN52C",28,0)
 I $P($G(PSOX("CS")),"^"),'+$P($G(^PSRX(PSOX("IRXN"),"PKI")),"^") S $P(^PSRX(PSOX("IRXN"),"PKI"),"^",2)=1
"RTN","PSORN52C",29,0)
 I $G(PSOX("SIG",1))]"",'$O(PSOX("SIG",1)) S ^PSRX(PSOX("IRXN"),"INS1",1,0)=PSOX("SIG",1),^PSRX(PSOX("IRXN"),"INS1",0)="^52.0115^1^1^"_DT_"^^"
"RTN","PSORN52C",30,0)
 I $O(^PSRX(PSOX("OIRXN"),"INS1",0)) D
"RTN","PSORN52C",31,0)
 .F D=0:0 S D=$O(^PSRX(PSOX("OIRXN"),"INS1",D)) Q:'D  S ^PSRX(PSOX("IRXN"),"INS1",D,0)=^PSRX(PSOX("OIRXN"),"INS1",D,0)
"RTN","PSORN52C",32,0)
 .S ^PSRX(PSOX("IRXN"),"INS1",0)=^PSRX(PSOX("OIRXN"),"INS1",0)
"RTN","PSORN52C",33,0)
TNT F I=1:1:PSOX("ENT") S ^PSRX(PSOX("IRXN"),6,I,0)=PSOX("DOSE",I)_"^"_$G(PSOX("DOSE ORDERED",I))_"^"_$G(PSOX("UNITS",I))_"^"_$G(PSOX("NOUN",I))_"^" D
"RTN","PSORN52C",34,0)
 .S ^PSRX(PSOX("IRXN"),6,I,0)=^PSRX(PSOX("IRXN"),6,I,0)_$G(PSOX("DURATION",I))_"^"_$G(PSOX("CONJUNCTION",I))_"^"_$G(PSOX("ROUTE",I))_"^"_$G(PSOX("SCHEDULE",I))_"^"_$G(PSOX("VERB",I))
"RTN","PSORN52C",35,0)
 .I $G(PSOX("ODOSE",I))]"" S ^PSRX(PSOX("IRXN"),6,I,1)=PSOX("ODOSE",I)
"RTN","PSORN52C",36,0)
 S:$G(PSOX("ENT")) ^PSRX(PSOX("IRXN"),6,0)="^52.0113^"_PSOX("ENT")_"^"_PSOX("ENT")
"RTN","PSORN52C",37,0)
 Q
"RTN","PSORN52C",38,0)
ORC ;
"RTN","PSORN52C",39,0)
 D MARK^PSOTPCAN
"RTN","PSORN52C",40,0)
 K PSORDEDT,GG,PSOHD,PSOID,PTST,PTDY,PTRF,RFCNT,RN,SEG1,SIG,SIGOK,DIC
"RTN","PSORN52C",41,0)
 K ST0,STA,STP,STR,JJ,LSI,MM,ORDG,ORIG,PHARMST,PSCAN,PSCNT,PSOI,GMRAL,DIC,DIE,HDR,IEN,NAME D KVA^VADPT
"RTN","PSORN52C",42,0)
 I $G(PSOFDR) D 
"RTN","PSORN52C",43,0)
 .I $G(PKI1)=1,$G(PKIR)]"" D ACT^PSOPKIV1(PSOX("IRXN"))
"RTN","PSORN52C",44,0)
 .S $P(^PSRX(PSOX("IRXN"),"OR1"),"^",2)=$P(OR0,"^"),^PSRX("APL",$P(OR0,"^"),PSOX("IRXN"))=""
"RTN","PSORN52C",45,0)
 .I $P($G(^PS(52.41,+$G(ORD),"EXT")),"^")="" I $G(PSOSIGFL)!($G(PSODRUG("OI"))'=$P(OR0,"^",8)) K:'$G(PSOPRC) PRC K PHI
"RTN","PSORN52C",46,0)
 .I $O(PRC(0)) S T=0 F  S T=$O(PRC(T)) Q:'T  S ^PSRX(PSOX("IRXN"),"PRC",T,0)=PRC(T),^PSRX(PSOX("IRXN"),"PRC",0)="^^"_T_"^"_T_"^"_DT_"^"
"RTN","PSORN52C",47,0)
 .I $O(PHI(0)) S T=0 F  S T=$O(PHI(T)) Q:'T  S ^PSRX(PSOX("IRXN"),"PI",T,0)=PHI(T),^PSRX(PSOX("IRXN"),"PI",0)="^^"_T_"^"_T_"^"_DT_"^"
"RTN","PSORN52C",48,0)
 .I $G(PSOSIGFL)!($G(PSODRUG("OI"))'=$P(OR0,"^",8)) D  S PSOI=1 Q
"RTN","PSORN52C",49,0)
 ..S POERR("PLACER")=$P(^PS(52.41,ORD,0),"^"),PSORDEDT=ORD
"RTN","PSORN52C",50,0)
 ..K ^PS(52.41,"AOR",PSODFN,+$P($G(^PS(52.41,ORD,"INI")),"^"),ORD)
"RTN","PSORN52C",51,0)
 ..S DA=ORD,DIK="^PS(52.41," D ^DIK
"RTN","PSORN52C",52,0)
 ..S $P(^PSRX(PSOX("IRXN"),"OR1"),"^")=$G(PSODRUG("OI"))
"RTN","PSORN52C",53,0)
 .E  S $P(^PSRX(PSOX("IRXN"),"OR1"),"^")=$P(OR0,"^",8)
"RTN","PSORN52C",54,0)
 .D PSOUL^PSSLOCK(ORD_"S") S DIK="^PS(52.41,",DA=ORD D ^DIK K DIK,DA
"RTN","PSORN52C",55,0)
 I $G(PSOX("OIRXN")),'$G(COPY) S $P(^PSRX(PSOX("IRXN"),"OR1"),"^",3)=PSOX("OIRXN"),$P(^PSRX(PSOX("OIRXN"),"OR1"),"^",4)=PSOX("IRXN"),^PSRX("AQ",PSOX("IRXN"),PSOX("OIRXN"))="" K PRC
"RTN","PSORN52C",56,0)
 I $O(PRC(0)) S T=0 F  S T=$O(PRC(T)) Q:'T  S ^PSRX(PSOX("IRXN"),"PRC",T,0)=PRC(T),^PSRX(PSOX("IRXN"),"PRC",0)="^^"_T_"^"_T_"^"_DT_"^"
"RTN","PSORN52C",57,0)
 I $O(PHI(0)) S T=0 F  S T=$O(PHI(T)) Q:'T  S ^PSRX(PSOX("IRXN"),"PI",T,0)=PHI(T),^PSRX(PSOX("IRXN"),"PI",0)="^^"_T_"^"_T_"^"_DT_"^"
"RTN","PSORN52C",58,0)
 S $P(^PSRX(PSOX("IRXN"),"OR1"),"^",5)=DUZ
"RTN","PSORN52C",59,0)
 S $P(^PSRX(PSOX("IRXN"),"OR1"),"^",8)=$$NOW^XLFDT D
"RTN","PSORN52C",60,0)
 . N DA,DIK S DA=PSOX("IRXN"),DIK="^PSRX(",DIK(1)=38.3 D EN1^DIK K DIK,DA
"RTN","PSORN52C",61,0)
 S PHARMST="",$P(^PSRX(PSOX("IRXN"),"OR1"),"^")=$G(PSODRUG("OI"))
"RTN","PSORN52C",62,0)
 S RXN=PSOX("IRXN") D SAVE
"RTN","PSORN52C",63,0)
 S STAT=$S($G(OR0)]""&('$G(PSOI)):"SC",$G(PSOI):"RO",1:"SN") S PHARMST=$S('$G(PSORX("VERIFY")):"CM",1:"IP") ;D EN^PSOHLSN1(RXN,STAT,PHARMST,"",PSONOOR)
"RTN","PSORN52C",64,0)
 S ^TMP("PSORXN",$J,RXN)=STAT_"^"_PHARMST_"^"_PSONOOR D PSOL^PSSLOCK(RXN)
"RTN","PSORN52C",65,0)
 D RESTORE K PSORDEDT,PHI,PRC,STAT,COMM,PSOI,OR2,OR1,PHARMST,RXN,DRG,STA,ACT,OCXR,OCXD1,OCXDT,OCXI
"RTN","PSORN52C",66,0)
 Q
"RTN","PSORN52C",67,0)
BBRX ;build bingo board Rx array; called by PSON52,PSOR52,PSORN52
"RTN","PSORN52C",68,0)
 I $G(BBRX(1))']"" S BBRX(1)=PSOX("IRXN")_"," Q
"RTN","PSORN52C",69,0)
 F PSOX1=0:0 S PSOX1=$O(BBRX(PSOX1)) Q:'PSOX1  S PSOX2=PSOX1
"RTN","PSORN52C",70,0)
 I $L(BBRX(PSOX2))+$L(PSOX("IRXN"))<220 S BBRX(PSOX2)=BBRX(PSOX2)_PSOX("IRXN")_","
"RTN","PSORN52C",71,0)
 E  S BBRX(PSOX2+1)=PSOX("IRXN")_","
"RTN","PSORN52C",72,0)
 Q
"RTN","PSORN52C",73,0)
SAVE ;this module will be used to save PSO arrays
"RTN","PSORN52C",74,0)
 K ^TMP("PSOLST",$J) F I=0:0 S I=$O(PSOLST(I)) Q:'I  S ^TMP("PSOLST",$J,I,0)=PSOLST(I)
"RTN","PSORN52C",75,0)
 K ^TMP("PSOSD",$J) S (STA,DRG)="" F  S STA=$O(PSOSD(STA)) Q:STA=""  F  S DRG=$O(PSOSD(STA,DRG)) Q:DRG=""  S ^TMP("PSOSD",$J,STA,DRG)=PSOSD(STA,DRG)
"RTN","PSORN52C",76,0)
 I $G(PSOSD) S ^TMP("PSOSD",$J,0)=PSOSD
"RTN","PSORN52C",77,0)
 I $G(PSODRUG("NAME"))]"" K ^TMP("PSODRUG",$J) S STA=""  F  S STA=$O(PSODRUG(STA)) Q:STA=""  D
"RTN","PSORN52C",78,0)
 .Q:STA="BAD"
"RTN","PSORN52C",79,0)
 .S ^TMP("PSODRUG",$J,STA)=PSODRUG(STA)
"RTN","PSORN52C",80,0)
 I $G(PSOX("# OF REFILLS"))]"" K ^TMP("PSOX",$J),^TMP("PSORENW",$J),^TMP("PSONEW",$J),^TMP("PSORXED",$J) D
"RTN","PSORN52C",81,0)
 .S STA="" F  S STA=$O(PSOX(STA)) Q:STA=""  S ^TMP("PSOX",$J,STA)=$G(PSOX(STA)) D
"RTN","PSORN52C",82,0)
 ..I STA="OLD LAST RX#",$O(PSOX(STA,"")) K ^TMP("PSOX",$J,STA) S ^TMP("PSOX",$J,STA,$O(PSOX(STA,"")))=PSOX(STA,$O(PSOX(STA,""))) D  Q
"RTN","PSORN52C",83,0)
 ...I $O(PSONEW(STA,"")) S ^TMP("PSONEW",$J,STA,$O(PSONEW(STA,"")))=PSONEW(STA,$O(PSONEW(STA,"")))
"RTN","PSORN52C",84,0)
 ...I $O(PSORENW(STA,"")) S ^TMP("PSORENW",$J,STA,$O(PSORENW(STA,"")))=PSORENW(STA,$O(PSORENW(STA,"")))
"RTN","PSORN52C",85,0)
 ...I $O(PSORXED(STA,"")) S ^TMP("PSORXED",$J,STA,$O(PSORXED(STA,"")))=PSORXED(STA,$O(PSORXED(STA,"")))
"RTN","PSORN52C",86,0)
 ..F ACT="PSORENW","PSONEW","PSORXED" I $G(@(ACT_"("""_STA_""")"))]"" S ^TMP(ACT,$J,STA)=@(ACT_"("""_STA_""")")
"RTN","PSORN52C",87,0)
 K PSOPTPST,PSOSD,PSONEW,PSOLST,PSORENW,PSORXED,PSODRUG
"RTN","PSORN52C",88,0)
 Q
"RTN","PSORN52C",89,0)
RESTORE ;this module restore saved arrays
"RTN","PSORN52C",90,0)
 S STA=0 F  S STA=$O(^TMP("PSOLST",$J,STA)) Q:'STA  S PSOLST(STA)=^TMP("PSOLST",$J,STA,0)
"RTN","PSORN52C",91,0)
 I $G(^TMP("PSOSD",$J,0)) S PSOSD=$G(^TMP("PSOSD",$J,0))
"RTN","PSORN52C",92,0)
 S (STA,DRG)="" F  S STA=$O(^TMP("PSOSD",$J,STA)) Q:STA=""  F  S DRG=$O(^TMP("PSOSD",$J,STA,DRG)) Q:DRG=""  S PSOSD(STA,DRG)=^TMP("PSOSD",$J,STA,DRG)
"RTN","PSORN52C",93,0)
 S STA="" F  S STA=$O(^TMP("PSODRUG",$J,STA)) Q:STA=""  S PSODRUG(STA)=^TMP("PSODRUG",$J,STA)
"RTN","PSORN52C",94,0)
 S STA="" F ACT="PSOX","PSORENW","PSONEW","PSORXED" D:$O(^TMP(ACT,$J,STA))]""
"RTN","PSORN52C",95,0)
 .F  S STA=$O(^TMP(ACT,$J,STA)) Q:STA=""  I STA'="OLD LAST RX#" S @(ACT_"("""_STA_""")")=^TMP(ACT,$J,STA)
"RTN","PSORN52C",96,0)
 I $O(^TMP("PSOX",$J,"OLD LAST RX#","")) S PSOX("OLD LAST RX#",$O(^TMP("PSOX",$J,"OLD LAST RX#","")))=^TMP("PSOX",$J,"OLD LAST RX#",$O(^TMP("PSOX",$J,"OLD LAST RX#","")))
"RTN","PSORN52C",97,0)
 I $O(^TMP("PSONEW",$J,"OLD LAST RX#","")) S PSONEW("OLD LAST RX#",$O(^TMP("PSONEW",$J,"OLD LAST RX#","")))=^TMP("PSONEW",$J,"OLD LAST RX#",$O(^TMP("PSONEW",$J,"OLD LAST RX#","")))
"RTN","PSORN52C",98,0)
 I $O(^TMP("PSORENW",$J,"OLD LAST RX#","")) S PSORENW("OLD LAST RX#",$O(^TMP("PSORENW",$J,"OLD LAST RX#","")))=^TMP("PSORENW",$J,"OLD LAST RX#",$O(^TMP("PSORENW",$J,"OLD LAST RX#","")))
"RTN","PSORN52C",99,0)
 I $O(^TMP("PSORXED",$J,"OLD LAST RX#","")) S PSORXED("OLD LAST RX#",$O(^TMP("PSORXED",$J,"OLD LAST RX#","")))=^TMP("PSORXED",$J,"OLD LAST RX#",$O(^TMP("PSORXED",$J,"OLD LAST RX#","")))
"RTN","PSORN52C",100,0)
 K ^TMP("PSOSD",$J),^TMP("PSODRUG",$J),^TMP("PSOX",$J),^TMP("PSORENW",$J),^TMP("PSONEW",$J),^TMP("PSORXED",$J),^TMP("PSOLST",$J)
"RTN","PSORN52C",101,0)
 Q
"RTN","PSORN52C",102,0)
 ;
"RTN","PSORN52C",103,0)
ACLOG ;activity log (digitally signed CS orders)
"RTN","PSORN52C",104,0)
 N DTTM,CNT,OCNT,XX
"RTN","PSORN52C",105,0)
 D NOW^%DTC S DTTM=%
"RTN","PSORN52C",106,0)
 S CNT=0 F XX=0:0 S XX=$O(^PSRX(PSOX("IRXN"),"A",XX)) Q:'XX  S CNT=XX
"RTN","PSORN52C",107,0)
 S OCNT=CNT
"RTN","PSORN52C",108,0)
 I $G(PSOCSP("NAME"))'=PSODRUG("NAME") S CNT=CNT+1,^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^NAME: "_PSOCSP("NAME")
"RTN","PSORN52C",109,0)
 S XX=0 F  S XX=$O(PSOCSP("DOSE",XX)) Q:'XX  I PSOCSP("DOSE",XX)'=$G(PSORENW("DOSE",XX)) D
"RTN","PSORN52C",110,0)
 .S CNT=CNT+1,^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^DOSAGE: "_PSOCSP("DOSE",XX)
"RTN","PSORN52C",111,0)
 S XX=0 F  S XX=$O(PSOCSP("DOSE ORDERED",XX)) Q:'XX  I PSOCSP("DOSE ORDERED",XX)'=$G(PSORENW("DOSE ORDERED",XX)) D
"RTN","PSORN52C",112,0)
 .S CNT=CNT+1,^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^DISPENSE UNITS: "_PSOCSP("DOSE ORDERED",XX)
"RTN","PSORN52C",113,0)
 I $G(PSOCSP("ISSUE DATE"))'=PSORENW("ISSUE DATE") S CNT=CNT+1,^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^ISSUE DATE: "_$$FMTE^XLFDT(PSOCSP("ISSUE DATE"))
"RTN","PSORN52C",114,0)
 I $G(PSOCSP("DAYS SUPPLY"))'=PSORENW("DAYS SUPPLY") S CNT=CNT+1,^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^DAYS SUPPLY: "_PSOCSP("DAYS SUPPLY")
"RTN","PSORN52C",115,0)
 I $G(PSOCSP("QTY"))'=PSORENW("QTY") S CNT=CNT+1,^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^QTY: "_PSOCSP("QTY")
"RTN","PSORN52C",116,0)
 I $G(PSOCSP("# OF REFILLS"))'=PSORENW("# OF REFILLS") S CNT=CNT+1,^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^# OF REFILLS: "_PSOCSP("# OF REFILLS")
"RTN","PSORN52C",117,0)
 I '$$SUBSCRIB^ORDEA($P(OR0,"^"),PSOX("IRXN")) S CNT=CNT+1,^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^ORDER DEA ARCHIVE INFO file entry failure"
"RTN","PSORN52C",118,0)
 I OCNT'=CNT S ^PSRX(PSOX("IRXN"),"A",0)="^52.3DA^"_CNT_"^"_CNT
"RTN","PSORN52C",119,0)
 Q
"RTN","PSORN52C",120,0)
 ;
"RTN","PSORXVW")
0^26^B77494288^B70126239
"RTN","PSORXVW",1,0)
PSORXVW ;BHAM ISC/SAB - listman view of a prescription ;5/25/05 2:10pm
"RTN","PSORXVW",2,0)
 ;;7.0;OUTPATIENT PHARMACY;**14,35,46,96,103,88,117,131,146,156,185,210,148,233,260,264,281,359,385,400,391**;DEC 1997;Build 13
"RTN","PSORXVW",3,0)
 ;External reference to File ^PS(55 supported by DBIA 2228
"RTN","PSORXVW",4,0)
 ;External reference to ^PS(50.7 supported by DBIA 2223
"RTN","PSORXVW",5,0)
 ;External reference ^PSDRUG( supported by DBIA 221
"RTN","PSORXVW",6,0)
 ;External reference to ^VA(200 supported by DBIA 10060
"RTN","PSORXVW",7,0)
 ;External reference to ^SC supported by DBIA 10040
"RTN","PSORXVW",8,0)
 ;External reference to ^DPT supported by DBIA 10035
"RTN","PSORXVW",9,0)
 ;External reference to ^PS(50.606 supported by DBIA 2174
"RTN","PSORXVW",10,0)
 ;External reference to GMRADPT supported by DBIA 10099
"RTN","PSORXVW",11,0)
 ;External reference to $$BADADR^DGUTL3 supported by DBIA 4080
"RTN","PSORXVW",12,0)
 ;
"RTN","PSORXVW",13,0)
 S PS="VIEW"
"RTN","PSORXVW",14,0)
A1 ; - Prescription prompt
"RTN","PSORXVW",15,0)
 S DIR(0)="FAO^1:30",DIR("A")=PS_" PRESCRIPTION: ",(DIR("?"),DIR("??"))="^D HLP^PSORXVW1"
"RTN","PSORXVW",16,0)
 W ! D ^DIR I X=""!$D(DIRUT) K:$G(PS)="VIEW" DA K PS G KILL
"RTN","PSORXVW",17,0)
 S X=$$UP^XLFSTR(X),QUIT=0
"RTN","PSORXVW",18,0)
 I $E(X,1,2)'="E." S (DA,PSOVDA)=+$$LKP^PSORXVW1(X) I DA<0 G A1
"RTN","PSORXVW",19,0)
 I $E(X,1,2)="E." D  I QUIT G A1   ; esg 12/7/10 - ECME# lookup - PSO*7*359
"RTN","PSORXVW",20,0)
 .S (DA,PSOVDA)=+$$RXNUM^PSOBPSU2($E(X,3,$L(X))) I DA<0 W " ??",$C(7) S QUIT=1
"RTN","PSORXVW",21,0)
 ;
"RTN","PSORXVW",22,0)
 ; pso*7*385 - esg - Routine BPSRVX is calling this routine here at entry point DP in order to capture the
"RTN","PSORXVW",23,0)
 ; scratch global data for the View ECME Rx option.  Special variable BPSVRX=1 in this case.
"RTN","PSORXVW",24,0)
DP ; DBIA #4711 entry point from ECME
"RTN","PSORXVW",25,0)
 ;
"RTN","PSORXVW",26,0)
 S (PSODFN,DFN)=+$P(^PSRX(DA,0),"^",2) S PSOLOUD=1 D:$P($G(^PS(55,PSODFN,0)),"^",6)'=2 EN^PSOHLUP(PSODFN) K PSOLOUD
"RTN","PSORXVW",27,0)
 D ICN^PSODPT(PSODFN)
"RTN","PSORXVW",28,0)
 K ^TMP("PSOHDR",$J) D ^VADPT,ADD^VADPT
"RTN","PSORXVW",29,0)
 S ^TMP("PSOHDR",$J,1,0)=VADM(1)
"RTN","PSORXVW",30,0)
 N PSOBADR,PSOTEMP
"RTN","PSORXVW",31,0)
 S PSOBADR=$$BADADR^DGUTL3(DFN) I PSOBADR S PSOTEMP=$$CHKTEMP^PSOBAI(DFN) D
"RTN","PSORXVW",32,0)
 .S ^TMP("PSOHDR",$J,1,0)=^TMP("PSOHDR",$J,1,0)_" ** BAD ADDRESS INDICATED-("_$S(PSOBADR=1:"UNDELIVERABLE",PSOBADR=2:"HOMELESS",1:"OTHER")_")"_$S(PSOTEMP:" Active Temporary Address",1:"")
"RTN","PSORXVW",33,0)
 S ^TMP("PSOHDR",$J,2,0)=$P(VADM(2),"^",2)
"RTN","PSORXVW",34,0)
 S ^TMP("PSOHDR",$J,3,0)=$P(VADM(3),"^",2),^TMP("PSOHDR",$J,4,0)=VADM(4),^TMP("PSOHDR",$J,5,0)=$P(VADM(5),"^",2)
"RTN","PSORXVW",35,0)
 S POERR=1 D RE^PSODEM K PSOERR
"RTN","PSORXVW",36,0)
 S ^TMP("PSOHDR",$J,6,0)=$S(+$P(WT,"^",8):$P(WT,"^",9)_" ("_$P(WT,"^")_")",1:"_______ (______)")
"RTN","PSORXVW",37,0)
 S ^TMP("PSOHDR",$J,7,0)=$S($P(HT,"^",8):$P(HT,"^",9)_" ("_$P(HT,"^")_")",1:"_______ (______)") K VM,WT,HT S PSOHD=7
"RTN","PSORXVW",38,0)
 S GMRA="0^0^111" D EN1^GMRADPT S ^TMP("PSOHDR",$J,8,0)=+$G(GMRAL)
"RTN","PSORXVW",39,0)
 D DEM^VADPT I +VADM(6) D
"RTN","PSORXVW",40,0)
 .S SSN=$P(^DPT(PSODFN,0),"^",9) W !,$C(7),?10,$P(^DPT(PSODFN,0),"^")_" ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_") DIED "_$P(VADM(6),"^",2),!
"RTN","PSORXVW",41,0)
 .W "All Active Medications will be Autocanceled!",! H 2 S PSODEATH=1
"RTN","PSORXVW",42,0)
 .S ACOM="Date of Death "_$P(VADM(6),"^",2)_".",ZTRTN="CAN^PSOCAN3",ZTDESC="Outpatient Pharmacy Autocancel Due to Death of Patient",ZTSAVE("ACOM")="",ZTSAVE("PSODFN")="",ZTSAVE("PSODEATH")=""
"RTN","PSORXVW",43,0)
 .S ZTIO="",PSOCLC=DUZ,ZTSAVE("PSOCLC")="",ZTDTH=$H D ^%ZTLOAD K ACOM,ZTSK,PSODEATH
"RTN","PSORXVW",44,0)
 K ^TMP("PSOAL",$J),PCOMX,PDA,PHI,PRC,ACOM,ANS
"RTN","PSORXVW",45,0)
 S (DA,RXN)=PSOVDA K PSOVDA S RX0=^PSRX(RXN,0),RX2=$G(^(2)),RX3=$G(^(3)),ST=+$G(^("STA")),RXOR=$G(^("OR1"))
"RTN","PSORXVW",46,0)
 I 'RXOR,$P(^PSDRUG($P(RX0,"^",6),2),"^") S $P(^PSRX(RXN,"OR1"),"^")=$P(^PSDRUG($P(RX0,"^",6),2),"^"),RXOR=$P(^PSDRUG($P(RX0,"^",6),2),"^")
"RTN","PSORXVW",47,0)
 S IEN=0,$P(RN," ",12)=" "
"RTN","PSORXVW",48,0)
 N APPND S APPND=$S($G(^PSRX(RXN,"IB")):"$",1:"")
"RTN","PSORXVW",49,0)
 I $$ECMENUM^PSOBPSU2(RXN)'="" S APPND=APPND_$$ECME^PSOBPSUT(RXN)_"  (ECME#: "_$$ECMENUM^PSOBPSU2(RXN)_")"
"RTN","PSORXVW",50,0)
 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$S($P($G(^PSRX(RXN,"TPB")),"^"):"            TPB Rx #: ",1:"                Rx #: ")_$P(RX0,"^")_APPND_$E(RN,$L($P(RX0,"^")_APPND)+1,12)
"RTN","PSORXVW",51,0)
 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="      Orderable Item: "_$S($D(^PS(50.7,$P(+RXOR,"^"),0)):$P(^PS(50.7,$P(+RXOR,"^"),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^"),1:"No Pharmacy Orderable Item")
"RTN","PSORXVW",52,0)
 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$S($D(^PSDRUG("AQ",$P(RX0,"^",6))):"           CMOP ",1:"                ")_"Drug: "_$P(^PSDRUG($P(RX0,"^",6),0),"^")
"RTN","PSORXVW",53,0)
 S:$G(^PSRX(RXN,"TN"))]"" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="          Trade Name: "_$G(^PSRX(RXN,"TN"))
"RTN","PSORXVW",54,0)
 I $$STATUS^PSOBPSUT(RXN,0)'="",$$RXRLDT^PSOBPSUT(RXN,0) D
"RTN","PSORXVW",55,0)
 . S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="                 NDC: "_$$GETNDC^PSONDCUT(RXN,0)
"RTN","PSORXVW",56,0)
 D DOSE^PSORXVW1
"RTN","PSORXVW",57,0)
 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Patient Instructions:" I $O(^PSRX(RXN,"INS1",0)) D
"RTN","PSORXVW",58,0)
 . F I=0:0 S I=$O(^PSRX(RXN,"INS1",I)) Q:'I  D
"RTN","PSORXVW",59,0)
 .. S MIG=^PSRX(RXN,"INS1",I,0)
"RTN","PSORXVW",60,0)
 .. D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOAL",$J)),21)
"RTN","PSORXVW",61,0)
 K MIG,SG
"RTN","PSORXVW",62,0)
 I $P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="  Other Pat. Instruc: "_$S($G(^PSRX(RXN,"INSS"))]"":^PSRX(RXN,"INSS"),1:"")
"RTN","PSORXVW",63,0)
 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="                 SIG:"
"RTN","PSORXVW",64,0)
 I '$P($G(^PSRX(RXN,"SIG")),"^",2) D  G PTST
"RTN","PSORXVW",65,0)
 . S X=$P($G(^PSRX(RXN,"SIG")),"^") D SIGONE^PSOHELP S SIG=$E($G(INS1),2,250)
"RTN","PSORXVW",66,0)
 . D WORDWRAP^PSOUTLA2(SIG,.IEN,$NA(^TMP("PSOAL",$J)),21)
"RTN","PSORXVW",67,0)
 S SIGOK=1
"RTN","PSORXVW",68,0)
 F I=0:0 S I=$O(^PSRX(RXN,"SIG1",I)) Q:'I  D
"RTN","PSORXVW",69,0)
 . S MIG=^PSRX(RXN,"SIG1",I,0)
"RTN","PSORXVW",70,0)
 . D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOAL",$J)),21)
"RTN","PSORXVW",71,0)
 S SIGOK=1 K MIG,SG
"RTN","PSORXVW",72,0)
PTST S $P(RN," ",25)=" ",PTST=$S($G(^PS(53,+$P(RX0,"^",3),0))]"":$P($G(^PS(53,+$P(RX0,"^",3),0)),"^"),1:""),IEN=IEN+1
"RTN","PSORXVW",73,0)
 S ^TMP("PSOAL",$J,IEN,0)="      Patient Status: "_PTST_$E(RN,$L(PTST)+1,25)
"RTN","PSORXVW",74,0)
 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="          Issue Date: "_$E($P(RX0,"^",13),4,5)_"/"_$E($P(RX0,"^",13),6,7)_"/"_$E($P(RX0,"^",13),2,3)
"RTN","PSORXVW",75,0)
 S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_"                 Fill Date: "_$E($P(RX2,"^",2),4,5)_"/"_$E($P(RX2,"^",2),6,7)_"/"_$E($P(RX2,"^",2),2,3)
"RTN","PSORXVW",76,0)
 S ROU=$S($P(RX0,"^",11)="W":"Window",1:"Mail")
"RTN","PSORXVW",77,0)
 S REFL=$P(RX0,"^",9),I=0 F  S I=$O(^PSRX(RXN,1,I)) Q:'I  S REFL=REFL-1,ROU=$S($P(^PSRX(RXN,1,I,0),"^",2)="W":"Window",1:"Mail")
"RTN","PSORXVW",78,0)
 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="      Last Fill Date: "_$E($P(RX3,"^"),4,5)_"/"_$E($P(RX3,"^"),6,7)_"/"_$E($P(RX3,"^"),2,3)
"RTN","PSORXVW",79,0)
 D CMOP^PSOORNE3 S DA=RXN
"RTN","PSORXVW",80,0)
 S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_" ("_ROU_$S($G(PSOCMOP)]"":", "_PSOCMOP,1:"")_")" K ROU,PSOCMOP
"RTN","PSORXVW",81,0)
 S IEN=IEN+1 I $P(RX2,"^",15) S ^TMP("PSOAL",$J,IEN,0)="   Returned to Stock: "_$E($P(RX2,"^",15),4,5)_"/"_$E($P(RX2,"^",15),6,7)_"/"_$E($P(RX2,"^",15),2,3)
"RTN","PSORXVW",82,0)
 E  S ^TMP("PSOAL",$J,IEN,0)="   Last Release Date: " D
"RTN","PSORXVW",83,0)
 .S RLD=$S($P(RX2,"^",13):$E($P(RX2,"^",13),4,5)_"/"_$E($P(RX2,"^",13),6,7)_"/"_$E($P(RX2,"^",13),2,3),1:"")
"RTN","PSORXVW",84,0)
 .I $O(^PSRX(RXN,1,0)) F I=0:0 S I=$O(^PSRX(RXN,1,I)) Q:'I  D
"RTN","PSORXVW",85,0)
 ..I $P(^PSRX(RXN,1,I,0),"^",18) S RLD=$E($P(^(0),"^",18),4,5)_"/"_$E($P(^(0),"^",18),6,7)_"/"_$E($P(^(0),"^",18),2,3)
"RTN","PSORXVW",86,0)
 .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_$S($G(RLD)]"":RLD,1:"        ")
"RTN","PSORXVW",87,0)
 S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_"                     Lot #: "_$P(RX2,"^",4)
"RTN","PSORXVW",88,0)
 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="             Expires: "_$E($P(RX2,"^",6),4,5)_"/"_$E($P(RX2,"^",6),6,7)_"/"_$E($P(RX2,"^",6),2,3)
"RTN","PSORXVW",89,0)
 S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_"                       MFG: "_$P($G(RX2),"^",8)
"RTN","PSORXVW",90,0)
 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="         Days Supply: "_$P(RX0,"^",8)_$S($L($P(RX0,"^",8))=1:" ",1:"")
"RTN","PSORXVW",91,0)
 S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_"                        QTY"_$S($P($G(^PSDRUG($P(RX0,"^",6),660)),"^",8)]"":" ("_$P($G(^PSDRUG($P(RX0,"^",6),660)),"^",8)_")",1:" (  )")_": "_$P(RX0,"^",7)
"RTN","PSORXVW",92,0)
 I $P($G(^PSDRUG($P(RX0,"^",6),5)),"^")]"" D
"RTN","PSORXVW",93,0)
 .S $P(RN," ",79)=" ",IEN=IEN+1
"RTN","PSORXVW",94,0)
 .S ^TMP("PSOAL",$J,IEN,0)=$E(RN,$L("QTY DSP MSG: "_$P(^PSDRUG($P(RX0,"^",6),5),"^"))+1,79)_"QTY DSP MSG: "_$P(^PSDRUG($P(RX0,"^",6),5),"^") K RN
"RTN","PSORXVW",95,0)
 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="        # of Refills: "_$P(RX0,"^",9)_$S($L($P(RX0,"^",9))=1:" ",1:"")_"                       Remaining: "_REFL
"RTN","PSORXVW",96,0)
 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="            Provider: "_$S($D(^VA(200,$P(RX0,"^",4),0)):$P(^VA(200,$P(RX0,"^",4),0),"^"),1:"UNKNOWN")
"RTN","PSORXVW",97,0)
 N DEAV S DEAV=+$P($G(^PSDRUG(+$P(RX0,"^",6),0)),"^",3) I DEAV>1,DEAV<6 D PRV K DEAV
"RTN","PSORXVW",98,0)
 I $P(RX3,"^",3) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="        Cos-Provider: "_$P(^VA(200,$P(RX3,"^",3),0),"^")
"RTN","PSORXVW",99,0)
 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="             Routing: "_$S($P(RX0,"^",11)="W":"Window",1:"Mail")
"RTN","PSORXVW",100,0)
 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="              Copies: "_$S($P(RX0,"^",18):$P(RX0,"^",18),1:1)
"RTN","PSORXVW",101,0)
 S:$P(RX0,"^",11)="W" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="    Method of Pickup: "_$G(^PSRX(RXN,"MP"))
"RTN","PSORXVW",102,0)
 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="              Clinic: "_$S($D(^SC(+$P(RX0,"^",5),0)):$P(^SC($P(RX0,"^",5),0),"^"),1:"Not on File")
"RTN","PSORXVW",103,0)
 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="            Division: "_$P(^PS(59,$P(RX2,"^",9),0),"^")_" ("_$P(^(0),"^",6)_")"
"RTN","PSORXVW",104,0)
 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="          Pharmacist: "_$S($P(RX2,"^",3):$P(^VA(200,$P(RX2,"^",3),0),"^"),1:"")
"RTN","PSORXVW",105,0)
 S:$P(RX2,"^",10)&('$G(PSOCOPY)) IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="         Verified By: "_$P(^VA(200,$P(RX2,"^",10),0),"^")
"RTN","PSORXVW",106,0)
 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="  Patient Counseling: "_$S($P($G(^PSRX(RXN,"PC")),"^"):"YES",1:"NO")_"                      "_$S($P($G(^PSRX(RXN,"PC")),"^"):"Was Counseling Understood: "_$S($P($G(^PSRX(RXN,"PC")),"^",2):"YES",1:"NO"),1:"")
"RTN","PSORXVW",107,0)
 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="             Remarks: "_$P(RX3,"^",7)
"RTN","PSORXVW",108,0)
 D PC^PSORXVW1
"RTN","PSORXVW",109,0)
 I $P($G(^PSRX(DA,"OR1")),"^",5) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="         Finished By: "_$P(^VA(200,$P(^PSRX(DA,"OR1"),"^",5),0),"^")
"RTN","PSORXVW",110,0)
 D ^PSORXVW1 S PSOAL=IEN K IEN,ACT,LBL,LOG
"RTN","PSORXVW",111,0)
 I ST<12,$P(RX2,"^",6)<DT S ST=11
"RTN","PSORXVW",112,0)
 S VALM("TITLE")="Rx View "_"("_$P("Error^Active^Non-Verified^Refill^Hold^Non-Verified^Suspended^^^^^Done^Expired^Discontinued^Deleted^Discontinued^Discontinued (Edit)^Provider Hold^","^",ST+2)_")"
"RTN","PSORXVW",113,0)
 S:$P($G(^PSRX(DA,"PKI")),"^") VALMSG="Digitally Signed Order"
"RTN","PSORXVW",114,0)
 ;
"RTN","PSORXVW",115,0)
 ; pso*7*385 - esg - if being called by the BPSVRX routine, call HDR^PSOLMUTL to build the VALMHDR array and then Quit
"RTN","PSORXVW",116,0)
 I $G(BPSVRX) D HDR^PSOLMUTL Q
"RTN","PSORXVW",117,0)
 ;
"RTN","PSORXVW",118,0)
 D EN^PSOORAL,KILL I $G(PS)="VIEW" G PSORXVW
"RTN","PSORXVW",119,0)
 K:$G(PS)="VIEW" DA K PS
"RTN","PSORXVW",120,0)
 Q
"RTN","PSORXVW",121,0)
 ;
"RTN","PSORXVW",122,0)
KILL K ^TMP("PSOAL",$J),PSOAL,IEN,^TMP("PSOHDR",$J) I $G(PS)="VIEW" K DA
"RTN","PSORXVW",123,0)
 K ST,RFL,RFLL,RFL1,ST,II,J,N,PHYS,L1,DIRUT,PSDIV,PSEXDT,MED,M1,FFX,DTT,DAT,RX0,RX2,R3,RTN,SIG,STA,P1,PL,P0,Z0,Z1,EXDT,IFN,DIR,DUOUT,DTOUT,PSOELSE
"RTN","PSORXVW",124,0)
 K LBL,I,RFDATE,%H,%I,RN,RFT,%,%I,DFN,GMRA,GMRAL,HDR,POERR,PTST,REFL,RF,RLD,RX3
"RTN","PSORXVW",125,0)
 K RXN,RXOR,SG,VA,VADM,VAERR,VALMBCK,VAPA,X,DIC,REA,ZD,PSOHD,PSOBCK,PSODFN,QUIT
"RTN","PSORXVW",126,0)
 Q
"RTN","PSORXVW",127,0)
 ;
"RTN","PSORXVW",128,0)
PRV       ;
"RTN","PSORXVW",129,0)
 N DETN,DEA,LBL,VADD,SPC,ORN S ORN=$P(^PSRX(RXN,"OR1"),"^",2)
"RTN","PSORXVW",130,0)
 S DEA=$$DEA^XUSER(0,$P(RX0,"^",4))
"RTN","PSORXVW",131,0)
 S LBL=$S(DEA["-":"  VA#: ",1:" DEA#: ")
"RTN","PSORXVW",132,0)
 S $P(SPC," ",(28-$L(DEA)))=" "
"RTN","PSORXVW",133,0)
 I $$DETOX^PSSOPKI($P(RX0,"^",6)) S DETN=$$DETOX^XUSER($P(RX0,"^",4))
"RTN","PSORXVW",134,0)
 I (DEA'="")!($G(DETN)'="") S IEN=IEN+1,$E(^TMP("PSOAL",$J,IEN,0),16)=LBL_DEA_$S($G(DETN)]"":SPC_"DETOX#: "_$G(DETN),1:"")
"RTN","PSORXVW",135,0)
 D PRVAD^PSOPKIV2
"RTN","PSORXVW",136,0)
 I $G(VADD(1))]"" D
"RTN","PSORXVW",137,0)
 .S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="        Site Address: "_VADD(1)
"RTN","PSORXVW",138,0)
 .S:VADD(2)]"" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="                      "_VADD(2) S:VADD(3)]"" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="                      "_VADD(3)
"RTN","PSORXVW",139,0)
 Q
"RTN","PSORXVW",140,0)
 ;
"RTN","PSOSIG")
0^33^B70011572^B63218715
"RTN","PSOSIG",1,0)
PSOSIG ;BIR/RTR-Utility to create SIG ;6/04/00
"RTN","PSOSIG",2,0)
 ;;7.0;OUTPATIENT PHARMACY;**46,99,114,391**;DEC 1997;Build 13
"RTN","PSOSIG",3,0)
 ;External reference to PS(51 supported by DBIA 2224
"RTN","PSOSIG",4,0)
 ;External reference to PS(51.1 supported by DBIA 2225
"RTN","PSOSIG",5,0)
 ;External reference to PSDRUG( supported by DBIA 221
"RTN","PSOSIG",6,0)
 ;
"RTN","PSOSIG",7,0)
EN(PSOSIGX) ;
"RTN","PSOSIG",8,0)
 N VARIABLE
"RTN","PSOSIG",9,0)
 Q
"RTN","PSOSIG",10,0)
SCH ;SCH = schedule entered     SCHEX = expanded schedule
"RTN","PSOSIG",11,0)
 N SQFLAG,SCLOOP,SCLP,SCLPS,SCLHOLD,SCIN,SODL,SST
"RTN","PSOSIG",12,0)
 K SCHEX S SQFLAG=0
"RTN","PSOSIG",13,0)
 I $G(SCH)="" S SCHEX="" Q
"RTN","PSOSIG",14,0)
 I SCH[""""!($A(SCH)=45)!(SCH?.E1C.E)!($L(SCH," ")>3)!($L(SCH)>20)!($L(SCH)<1) K SCH Q
"RTN","PSOSIG",15,0)
 N PSOSCUP S SCH=$$UPPER(SCH)
"RTN","PSOSIG",16,0)
 F SCLOOP=0:0 S SCLOOP=$O(^PS(51.1,"B",SCH,SCLOOP)) Q:'SCLOOP!(SQFLAG)  I $P($G(^PS(51.1,SCLOOP,0)),"^",8)'="" S SCHEX=$P($G(^(0)),"^",8),SQFLAG=1
"RTN","PSOSIG",17,0)
 Q:SQFLAG
"RTN","PSOSIG",18,0)
 I $P($G(^PS(51,"A",SCH)),"^")'="" S SCHEX=$P(^(SCH),"^") Q
"RTN","PSOSIG",19,0)
 S SCLOOP=0 F SCLP=1:1:$L(SCH) S SCLPS=$E(SCH,SCLP) I SCLPS=" " S SCLOOP=SCLOOP+1
"RTN","PSOSIG",20,0)
 I SCLOOP=0 S SCHEX=SCH Q
"RTN","PSOSIG",21,0)
 S SCLOOP=SCLOOP+1
"RTN","PSOSIG",22,0)
 K SCLHOLD F SCIN=1:1:SCLOOP S (SODL,SCLHOLD(SCIN))=$P(SCH," ",SCIN) D
"RTN","PSOSIG",23,0)
 .Q:$G(SODL)=""
"RTN","PSOSIG",24,0)
 .S SQFLAG=0 F SST=0:0 S SST=$O(^PS(51.1,"B",SODL,SST)) Q:'SST!($G(SQFLAG))  I $P($G(^PS(51.1,SST,0)),"^",8)'="" S SCLHOLD(SCIN)=$P($G(^(0)),"^",8),SQFLAG=1
"RTN","PSOSIG",25,0)
 .Q:$G(SQFLAG)
"RTN","PSOSIG",26,0)
 .I $P($G(^PS(51,"A",SODL)),"^")'="" S SCLHOLD(SCIN)=$P(^(SODL),"^")
"RTN","PSOSIG",27,0)
 S SCHEX="",SQFLAG=0 F SST=1:1:SCLOOP S SCHEX=SCHEX_$S($G(SQFLAG):" ",1:"")_$G(SCLHOLD(SST)),SQFLAG=1
"RTN","PSOSIG",28,0)
 Q
"RTN","PSOSIG",29,0)
QTY(PSOQX) ;
"RTN","PSOSIG",30,0)
 N QDOSE
"RTN","PSOSIG",31,0)
 K PSOQX("QTY")
"RTN","PSOSIG",32,0)
 I $G(PSOFDR),'$G(CPRN) N PSOQTYQT,PSOLPSD S PSOQTYQT=0 D  I $G(PSOQTYQT) Q
"RTN","PSOSIG",33,0)
 .S PSOLPSD="" F  S PSOLPSD=$O(PSONEW("SCHEDULE",PSOLPSD)) Q:PSOLPSD=""!(PSOQTYQT)  I $G(PSONEW("SCHEDULE",PSOLPSD))["PRN"!($G(PSONEW("SCHEDULE",PSOLPSD))["prn")!($G(PSONEW("SCHEDULE",PSOLPSD))["Prn") S PSOQTYQT=1 Q
"RTN","PSOSIG",34,0)
 N PSOOUTQT S PSOOUTQT=1
"RTN","PSOSIG",35,0)
QTYCP ;CPRS qty call comes through here
"RTN","PSOSIG",36,0)
 N PSQQUIT,QTSH,PSQ,PSQMIN,PSQMINZ,PSOQRND,PSOLOWER,PSOLOWX,PSOLOWXL,PSOLOWST
"RTN","PSOSIG",37,0)
 K PSOFRQ S PSQQUIT=0
"RTN","PSOSIG",38,0)
 I '$G(PSOCPRQT) S QDOSE=0 F PSQ=0:0 S PSQ=$O(PSOQX("DOSE",PSQ)) Q:'PSQ  S QDOSE=PSQ S:'$G(PSOQX("DOSE ORDERED",PSQ)) PSQQUIT=1
"RTN","PSOSIG",39,0)
 ;Q:PSQQUIT!('QDOSE)
"RTN","PSOSIG",40,0)
 I '$G(PSOCPRQT) Q:PSQQUIT
"RTN","PSOSIG",41,0)
 Q:'$G(PSOQX("DAYS SUPPLY"))
"RTN","PSOSIG",42,0)
 Q:'$G(QDOSE)
"RTN","PSOSIG",43,0)
 G:QDOSE>1 COMP
"RTN","PSOSIG",44,0)
 Q:'$G(PSOQX("DOSE ORDERED",1))
"RTN","PSOSIG",45,0)
 Q:'$G(PSOQX("DAYS SUPPLY"))&('$G(PSOQX("DURATION",1)))
"RTN","PSOSIG",46,0)
 S PSOLOWER=0
"RTN","PSOSIG",47,0)
 I $G(PSOQX("DURATION",1)) D
"RTN","PSOSIG",48,0)
 .S PSOLOWX=$L(PSOQX("DURATION",1))
"RTN","PSOSIG",49,0)
 .S PSOLOWXL=$S($E(PSOQX("DURATION",1),PSOLOWX)="M":1,$E(PSOQX("DURATION",1),PSOLOWX)="H":60,$E(PSOQX("DURATION",1),PSOLOWX)="S":.01666,$E(PSOQX("DURATION",1),PSOLOWX)="W":10080,$E(PSOQX("DURATION",1),PSOLOWX)="L":43200,1:1440)
"RTN","PSOSIG",50,0)
 .S PSOLOWER=PSOLOWXL*(+$G(PSOQX("DURATION",1)))
"RTN","PSOSIG",51,0)
 S PSOLOWX=0 I +$G(PSOQX("DAYS SUPPLY")) S PSOLOWX=1440*+$G(PSOQX("DAYS SUPPLY"))
"RTN","PSOSIG",52,0)
 Q:'$G(PSOLOWER)&('$G(PSOLOWX))
"RTN","PSOSIG",53,0)
 S QTSH=$G(PSOQX("SCHEDULE",1)) D QTS Q:PSQQUIT!('$G(PSOFRQ))
"RTN","PSOSIG",54,0)
 S PSOLOWST=$S('$G(PSOLOWER):$G(PSOLOWX),'$G(PSOLOWX):$G(PSOLOWER),$G(PSOLOWER)>$G(PSOLOWX):$G(PSOLOWX),$G(PSOLOWX)>$G(PSOLOWER):$G(PSOLOWER),$G(PSOLOWX)=$G(PSOLOWER):$G(PSOLOWER),1:0)
"RTN","PSOSIG",55,0)
 Q:'$G(PSOLOWST)
"RTN","PSOSIG",56,0)
 S PSQMIN=+$G(PSOLOWST)
"RTN","PSOSIG",57,0)
 S PSQMINZ=PSQMIN/PSOFRQ
"RTN","PSOSIG",58,0)
 S PSOQRND=PSQMINZ*+$G(PSOQX("DOSE ORDERED",1)) Q:'PSOQRND
"RTN","PSOSIG",59,0)
 D ROUND G QEND
"RTN","PSOSIG",60,0)
 Q
"RTN","PSOSIG",61,0)
COMP ;COMPLEX DOSE HERE
"RTN","PSOSIG",62,0)
 N PSOQEXC,PSOQAND,PSOQTHEN,PSQL,PSQMNL,PSQMNLX,PSODUTOT,PSODUDIF,PSODUMIS,PSODUREP,PSQ1,PSODUX,PSODUXX,PSODSMIN
"RTN","PSOSIG",63,0)
 ;PSODUTOT = TOTAL OF ALL DURATIONS
"RTN","PSOSIG",64,0)
 ;PSODUDIF = DIFF. OF DURATION VS DAYS SUPPLY
"RTN","PSOSIG",65,0)
 ;PSODUMIS = # OF SEQUENCES MISSING A DURATION IF >1 CAN'T DEFAULT
"RTN","PSOSIG",66,0)
 ;PSODUREP = SEQUENCE # THAT IS MISSING DURATION
"RTN","PSOSIG",67,0)
 ;PSODSMIN = MINUTES OF DAYS SUPPLY
"RTN","PSOSIG",68,0)
 S (PSODUTOT,PSODUDIF,PSODUMIS,PSODUREP,PSODSMIN,PSOQAND,PSOQTHEN,PSOQEXC)=0
"RTN","PSOSIG",69,0)
 F PSQL=1:1:QDOSE S:$G(PSOQX("CONJUNCTION",PSQL))["A" PSOQAND=1 S:$G(PSOQX("CONJUNCTION",PSQL))["T" PSOQTHEN=1 S:$G(PSOQX("CONJUNCTION",PSQL))["X" PSOQEXC=1
"RTN","PSOSIG",70,0)
 I $G(PSOQEXC) G QEND
"RTN","PSOSIG",71,0)
 I $G(PSOQAND) G COMP^PSOSIGCX
"RTN","PSOSIG",72,0)
 F PSQ1=1:1:QDOSE D  Q:PSODUMIS>1
"RTN","PSOSIG",73,0)
 .I '$G(PSOQX("DURATION",PSQ1)) S PSODUMIS=PSODUMIS+1,PSODUREP=PSQ1 Q
"RTN","PSOSIG",74,0)
 .S PSODUX=$L(PSOQX("DURATION",PSQ1))
"RTN","PSOSIG",75,0)
 .S PSODUXX=$S($E(PSOQX("DURATION",PSQ1),PSODUX)="M":1,$E(PSOQX("DURATION",PSQ1),PSODUX)="H":60,$E(PSOQX("DURATION",PSQ1),PSODUX)="S":.01666,$E(PSOQX("DURATION",PSQ1),PSODUX)="W":10080,$E(PSOQX("DURATION",PSQ1),PSODUX)="L":43200,1:1440)
"RTN","PSOSIG",76,0)
 .S PSODUTOT=PSODUTOT+(PSODUXX*(+$G(PSOQX("DURATION",PSQ1))))
"RTN","PSOSIG",77,0)
 G:PSODUMIS>1 QEND ; More than 1 sequence missing a duration
"RTN","PSOSIG",78,0)
 I $G(PSODUMIS),'$G(PSOQX("DAYS SUPPLY")) G QEND ; missing 1 duration, no days supply
"RTN","PSOSIG",79,0)
 S PSODSMIN=1440*+$G(PSOQX("DAYS SUPPLY"))
"RTN","PSOSIG",80,0)
 I $G(PSODSMIN),$G(PSODSMIN)<$G(PSODUTOT) G QEND
"RTN","PSOSIG",81,0)
 I '$G(PSODUMIS),$G(PSODSMIN),$G(PSODUTOT)>$G(PSODSMIN) G QEND ; no missing durations, but total durations are greater than days supply
"RTN","PSOSIG",82,0)
 I $G(PSODUMIS),$G(PSODSMIN),$G(PSODSMIN)'>$G(PSODUTOT) G QEND ; 1 missing duration, and total of other durations are not less than days supply
"RTN","PSOSIG",83,0)
 I '$G(PSODSMIN),$G(PSODUMIS) G QEND ; no days supply, missing a duration
"RTN","PSOSIG",84,0)
 I $G(PSODUREP) S PSODUDIF=$G(PSODSMIN)-$G(PSODUTOT)
"RTN","PSOSIG",85,0)
 F PSQ=1:1:QDOSE D  Q:$G(PSQQUIT)
"RTN","PSOSIG",86,0)
 .I '$G(PSOQX("DOSE ORDERED",PSQ))!($G(PSOQX("SCHEDULE",PSQ))="") S PSQQUIT=1 Q
"RTN","PSOSIG",87,0)
 .S QTSH=$G(PSOQX("SCHEDULE",PSQ)) D QTS S:'$G(PSOFRQ) PSQQUIT=1 Q:$G(PSQQUIT)
"RTN","PSOSIG",88,0)
 .I $G(PSOQX("DURATION",PSQ)) S PSQMNL=$L(PSOQX("DURATION",PSQ)) D
"RTN","PSOSIG",89,0)
 ..S PSQMNLX=$S($E(PSOQX("DURATION",PSQ),PSQMNL)="M":1,$E(PSOQX("DURATION",PSQ),PSQMNL)="H":60,$E(PSOQX("DURATION",PSQ),PSQMNL)="S":.01666,$E(PSOQX("DURATION",PSQ),PSQMNL)="W":10080,$E(PSOQX("DURATION",PSQ),PSQMNL)="L":43200,1:1440)
"RTN","PSOSIG",90,0)
 ..S PSQMIN=PSQMNLX*(+$G(PSOQX("DURATION",PSQ)))
"RTN","PSOSIG",91,0)
 .I '$G(PSOQX("DURATION",PSQ)) S PSQMIN=$G(PSODUDIF)
"RTN","PSOSIG",92,0)
 .S PSQMINZ=PSQMIN/PSOFRQ
"RTN","PSOSIG",93,0)
 .S PSOQRND=$S('$G(PSOQRND):PSQMINZ*+$G(PSOQX("DOSE ORDERED",PSQ)),1:$G(PSOQRND)+(PSQMINZ*+$G(PSOQX("DOSE ORDERED",PSQ))))
"RTN","PSOSIG",94,0)
 I $G(PSQQUIT) G QEND
"RTN","PSOSIG",95,0)
 I $G(PSOQRND) D ROUND
"RTN","PSOSIG",96,0)
 G QEND
"RTN","PSOSIG",97,0)
QTS ;Find frequency
"RTN","PSOSIG",98,0)
 ;QTSH = SHCEDULE
"RTN","PSOSIG",99,0)
 ;either return PSOFRQ for frequency or PSSQUIT for no frequency
"RTN","PSOSIG",100,0)
 N SQTFLAG,SQQT,ZZQT,ZZQ,ZZQQ,ZQHOLD,QGLFLAG,PZQT,ZDL,ZZQX
"RTN","PSOSIG",101,0)
 K PSOFRQ
"RTN","PSOSIG",102,0)
 S (QGLFLAG,ZZQX)=0
"RTN","PSOSIG",103,0)
 I $G(QTSH)="" S PSQQUIT=1 Q
"RTN","PSOSIG",104,0)
 S SQTFLAG=0 F SQQT=0:0 S SQQT=$O(^PS(51.1,"B",QTSH,SQQT)) Q:'SQQT!($G(SQTFLAG))  I $P($G(^PS(51.1,SQQT,0)),"^",3) S PSOFRQ=$P($G(^(0)),"^",3),SQTFLAG=1
"RTN","PSOSIG",105,0)
 Q:SQTFLAG
"RTN","PSOSIG",106,0)
 F SQQT=0:0 S SQQT=$O(^PS(51,"B",QTSH,SQQT)) Q:'SQQT!($G(SQTFLAG))  I $P($G(^PS(51,SQQT,0)),"^",8) S PSOFRQ=$P($G(^(0)),"^",8),SQTFLAG=1
"RTN","PSOSIG",107,0)
 Q:SQTFLAG
"RTN","PSOSIG",108,0)
 S ZZQT=0 F ZZQ=1:1:$L(QTSH) S ZZQQ=$E(QTSH,ZZQ) I ZZQQ=" " S ZZQT=ZZQT+1
"RTN","PSOSIG",109,0)
 I 'ZZQT S PSQQUIT=1 Q
"RTN","PSOSIG",110,0)
 S ZZQT=ZZQT+1
"RTN","PSOSIG",111,0)
 K ZQHOLD S QGLFLAG=0 F PZQT=1:1:ZZQT S (ZDL,ZQHOLD)=$P(QTSH," ",PZQT) D
"RTN","PSOSIG",112,0)
 .Q:$G(ZDL)=""
"RTN","PSOSIG",113,0)
 .S ZZQX=0 F SQQT=0:0 S SQQT=$O(^PS(51.1,"B",ZDL,SQQT)) Q:'SQQT!($G(ZZQX))  I $P($G(^PS(51.1,SQQT,0)),"^",3) S PSOFRQ=$P($G(^(0)),"^",3),ZZQX=1,QGLFLAG=QGLFLAG+1
"RTN","PSOSIG",114,0)
 .Q:ZZQX
"RTN","PSOSIG",115,0)
 .S ZZQX=0 F SQQT=0:0 S SQQT=$O(^PS(51,"B",ZDL,SQQT)) Q:'SQQT!($G(ZZQX))  I $P($G(^PS(51,SQQT,0)),"^",8) S PSOFRQ=$P($G(^(0)),"^",8),ZZQX=1,QGLFLAG=QGLFLAG+1
"RTN","PSOSIG",116,0)
 I $G(QGLFLAG)>1 K PSOFRQ
"RTN","PSOSIG",117,0)
 I '$G(PSOFRQ) S PSQQUIT=1
"RTN","PSOSIG",118,0)
 Q
"RTN","PSOSIG",119,0)
QEND ;
"RTN","PSOSIG",120,0)
 K PSOFRQ
"RTN","PSOSIG",121,0)
 I $G(PSOOUTQT),$G(QTYHLD),$G(PSOQX("QTY")),$G(QTYHLD)'=$G(PSOQX("QTY")) W !!!,"Quantity has been changed from "_QTYHLD_" to "_PSOQX("QTY") D  W ! N DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR W !
"RTN","PSOSIG",122,0)
 .I $G(PSONEW("FLD"))=8,$P($G(OR0),"^",24),$G(PSODRUG("IEN")),$D(^PSDRUG(+$G(PSODRUG("IEN")),0)) D
"RTN","PSOSIG",123,0)
 ..I $P(^PSDRUG(PSODRUG("IEN"),0),"^",3)[2!($P(^PSDRUG(PSODRUG("IEN"),0),"^",3)["F") Q
"RTN","PSOSIG",124,0)
 ..N ZRFA S ZRFA=$S($G(CLOZPAT)=2&(PSOQX("DAYS SUPPLY")=14):1,$G(CLOZPAT)=2&(PSOQX("DAYS SUPPLY")=7):3,$G(CLOZPAT)=1&(PSOQX("DAYS SUPPLY")=7):1,$D(CLOZPAT):0,1:5)
"RTN","PSOSIG",125,0)
 ..N ZREF,ZTQ S ZREF=QTYHLD\PSOQX("QTY") I ZREF>0 D
"RTN","PSOSIG",126,0)
 ...S ZTQ=QTYHLD*(PSOQX("# OF REFILLS")+1),ZTQ=ZTQ-PSOQX("QTY"),ZREF=ZTQ\PSOQX("QTY") S:ZREF>ZRFA ZREF=ZRFA
"RTN","PSOSIG",127,0)
 ...I ZREF'=PSOQX("# OF REFILLS") W !,"# of Refills has been changed from "_PSOQX("# OF REFILLS")_" to "_ZREF S PSOQX("# OF REFILLS")=ZREF
"RTN","PSOSIG",128,0)
 Q
"RTN","PSOSIG",129,0)
ROUND ;
"RTN","PSOSIG",130,0)
 Q:'$G(PSOQRND)
"RTN","PSOSIG",131,0)
 I PSOQRND'["." S PSOQX("QTY")=PSOQRND Q
"RTN","PSOSIG",132,0)
 S PSOQX("QTY")=$P(PSOQRND,".")+1
"RTN","PSOSIG",133,0)
 Q
"RTN","PSOSIG",134,0)
DAY(DATE) ;First 5 digits of FileMan date
"RTN","PSOSIG",135,0)
 N X
"RTN","PSOSIG",136,0)
 I DATE'?5N Q -1
"RTN","PSOSIG",137,0)
 S X=$E(DATE,4,5) I X<1!(X>12) Q -1
"RTN","PSOSIG",138,0)
 S X=DATE+1+(X=12*88)_"01"
"RTN","PSOSIG",139,0)
 Q $E($$FMADD^XLFDT(X,-1),6,7)
"RTN","PSOSIG",140,0)
 ;
"RTN","PSOSIG",141,0)
QTYX(PSOQX) ;
"RTN","PSOSIG",142,0)
 N PSOQLP,PSOQLN,PSOQAR,PSOCPRQT,QDOSE,QDOSEX S PSOCPRQT=1 F PSOQLP=0:0 S PSOQLP=$O(PSOQX("DURATION",PSOQLP)) Q:'PSOQLP  D
"RTN","PSOSIG",143,0)
 .S PSOQAR("DURATION",PSOQLP)=$G(PSOQX("DURATION",PSOQLP))
"RTN","PSOSIG",144,0)
 .I $E(PSOQX("DURATION",PSOQLP))?1A S PSOQLN=$L(PSOQX("DURATION",PSOQLP)) S PSOQX("DURATION",PSOQLP)=$E(PSOQX("DURATION",PSOQLP),2,PSOQLN)_$E(PSOQX("DURATION",PSOQLP))
"RTN","PSOSIG",145,0)
 S QDOSE=0 F QDOSEX=0:0 S QDOSEX=$O(PSOQX("DOSE ORDERED",QDOSEX)) Q:'QDOSEX  S QDOSE=QDOSE+1
"RTN","PSOSIG",146,0)
 I '$G(PSOQX("QTY")) D QTYCP G QPASS
"RTN","PSOSIG",147,0)
 D QTYCP^PSOSIGDS
"RTN","PSOSIG",148,0)
QPASS F PSOQLP=0:0 S PSOQLP=$O(PSOQAR("DURATION",PSOQLP)) Q:'PSOQLP  D
"RTN","PSOSIG",149,0)
 .S PSOQX("DURATION",PSOQLP)=$G(PSOQAR("DURATION",PSOQLP))
"RTN","PSOSIG",150,0)
 K PSOCPRQT
"RTN","PSOSIG",151,0)
 Q
"RTN","PSOSIG",152,0)
DAYS(PSOQX) ;Entry point for Days Supply calc for PSO
"RTN","PSOSIG",153,0)
 ;Kill days supply here
"RTN","PSOSIG",154,0)
 Q:'$G(PSOQX("QTY"))
"RTN","PSOSIG",155,0)
 D QTYOPS^PSOSIGDS
"RTN","PSOSIG",156,0)
 Q
"RTN","PSOSIG",157,0)
 ;
"RTN","PSOSIG",158,0)
UPPER(PSOSCUP) ;
"RTN","PSOSIG",159,0)
 Q $TR(PSOSCUP,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
"RTN","PSOSIGDS")
0^36^B68186224^B62109134
"RTN","PSOSIGDS",1,0)
PSOSIGDS ;BIR/RTR-Utility to calculate Days Supply ;6/04/00
"RTN","PSOSIGDS",2,0)
 ;;7.0;OUTPATIENT PHARMACY;**46,222,391**;DEC 1997;Build 13
"RTN","PSOSIGDS",3,0)
 ;External reference to PS(51 supported by DBIA 2224
"RTN","PSOSIGDS",4,0)
 ;External reference to PS(51.1 supported by DBIA 2225
"RTN","PSOSIGDS",5,0)
 ;External reference to PS(55 supported by DBIA 2228
"RTN","PSOSIGDS",6,0)
 ;External reference to PSDRUG( supported by DBIA 221
"RTN","PSOSIGDS",7,0)
 ;External reference to YSCL(603.01 supported by DBIA 2697
"RTN","PSOSIGDS",8,0)
 ;
"RTN","PSOSIGDS",9,0)
EN(PSOSIGX) ;
"RTN","PSOSIGDS",10,0)
 N VARIABLE
"RTN","PSOSIGDS",11,0)
 Q
"RTN","PSOSIGDS",12,0)
SCH ;SCH = schedule entered     SCHEX = expanded schedule
"RTN","PSOSIGDS",13,0)
 N SQFLAG,SCLOOP,SCLP,SCLPS,SCLHOLD,SCIN,SODL,SST
"RTN","PSOSIGDS",14,0)
 K SCHEX S SQFLAG=0
"RTN","PSOSIGDS",15,0)
 I $G(SCH)="" S SCHEX="" Q
"RTN","PSOSIGDS",16,0)
 F SCLOOP=0:0 S SCLOOP=$O(^PS(51.1,"B",SCH,SCLOOP)) Q:'SCLOOP!(SQFLAG)  I $P($G(^PS(51.1,SCLOOP,0)),"^",8)'="" S SCHEX=$P($G(^(0)),"^",8),SQFLAG=1
"RTN","PSOSIGDS",17,0)
 Q:SQFLAG
"RTN","PSOSIGDS",18,0)
 I $P($G(^PS(51,"A",SCH)),"^")'="" S SCHEX=$P(^(SCH),"^") Q
"RTN","PSOSIGDS",19,0)
 S SCLOOP=0 F SCLP=1:1:$L(SCH) S SCLPS=$E(SCH,SCLP) I SCLPS=" " S SCLOOP=SCLOOP+1
"RTN","PSOSIGDS",20,0)
 I SCLOOP=0 S SCHEX=SCH Q
"RTN","PSOSIGDS",21,0)
 S SCLOOP=SCLOOP+1
"RTN","PSOSIGDS",22,0)
 K SCLHOLD F SCIN=1:1:SCLOOP S (SODL,SCLHOLD(SCIN))=$P(SCH," ",SCIN) D
"RTN","PSOSIGDS",23,0)
 .Q:$G(SODL)=""
"RTN","PSOSIGDS",24,0)
 .S SQFLAG=0 F SST=0:0 S SST=$O(^PS(51.1,"B",SODL,SST)) Q:'SST!($G(SQFLAG))  I $P($G(^PS(51.1,SST,0)),"^",8)'="" S SCLHOLD(SCIN)=$P($G(^(0)),"^",8),SQFLAG=1
"RTN","PSOSIGDS",25,0)
 .Q:$G(SQFLAG)
"RTN","PSOSIGDS",26,0)
 .I $P($G(^PS(51,"A",SODL)),"^")'="" S SCLHOLD(SCIN)=$P(^(SODL),"^")
"RTN","PSOSIGDS",27,0)
 S SCHEX="",SQFLAG=0 F SST=1:1:SCLOOP S SCHEX=SCHEX_$S($G(SQFLAG):" ",1:"")_$G(SCLHOLD(SST)),SQFLAG=1
"RTN","PSOSIGDS",28,0)
 Q
"RTN","PSOSIGDS",29,0)
QTY(PSOQX) ;
"RTN","PSOSIGDS",30,0)
 Q
"RTN","PSOSIGDS",31,0)
QTYOPS ;
"RTN","PSOSIGDS",32,0)
 N QDOSE
"RTN","PSOSIGDS",33,0)
QTYCP ;CPRS days supply call comes through here
"RTN","PSOSIGDS",34,0)
 N PSOZMIN,PSQQUIT,QTSH,PSQ,PSQMIN,PSQMINZ,PSOQRND,PSOLOWER,PSOLOWX,PSOLOWXL,PSOLOWST
"RTN","PSOSIGDS",35,0)
 K PSOFRQ S PSQQUIT=0
"RTN","PSOSIGDS",36,0)
 I '$G(PSOCPRQT) S QDOSE=0 F PSQ=0:0 S PSQ=$O(PSOQX("DOSE",PSQ)) Q:'PSQ  S QDOSE=PSQ S:'$G(PSOQX("DOSE ORDERED",PSQ)) PSQQUIT=1
"RTN","PSOSIGDS",37,0)
 ;Q:PSQQUIT!('QDOSE)
"RTN","PSOSIGDS",38,0)
 I '$G(PSOCPRQT) Q:PSQQUIT
"RTN","PSOSIGDS",39,0)
 Q:'$G(QDOSE)
"RTN","PSOSIGDS",40,0)
 G:QDOSE>1 COMP
"RTN","PSOSIGDS",41,0)
 Q:'$G(PSOQX("DOSE ORDERED",1))
"RTN","PSOSIGDS",42,0)
 ;Q:'$G(PSOQX("DAYS SUPPLY"))&('$G(PSOQX("DURATION",1)))
"RTN","PSOSIGDS",43,0)
 S PSOLOWER=0
"RTN","PSOSIGDS",44,0)
 I $G(PSOQX("DURATION",1)) D
"RTN","PSOSIGDS",45,0)
 .S PSOLOWX=$L(PSOQX("DURATION",1))
"RTN","PSOSIGDS",46,0)
 .S PSOLOWXL=$S($E(PSOQX("DURATION",1),PSOLOWX)="M":1,$E(PSOQX("DURATION",1),PSOLOWX)="H":60,$E(PSOQX("DURATION",1),PSOLOWX)="S":.01666,$E(PSOQX("DURATION",1),PSOLOWX)="W":10080,$E(PSOQX("DURATION",1),PSOLOWX)="L":43200,1:1440)
"RTN","PSOSIGDS",47,0)
 .S PSOLOWER=PSOLOWXL*(+$G(PSOQX("DURATION",1)))
"RTN","PSOSIGDS",48,0)
 ;S PSOLOWX=0 I +$G(PSOQX("DAYS SUPPLY")) S PSOLOWX=1440*+$G(PSOQX("DAYS SUPPLY"))
"RTN","PSOSIGDS",49,0)
 ;Q:'$G(PSOLOWER)&('$G(PSOLOWX))
"RTN","PSOSIGDS",50,0)
 S QTSH=$G(PSOQX("SCHEDULE",1)) D QTS Q:PSQQUIT!('$G(PSOFRQ))
"RTN","PSOSIGDS",51,0)
 ;S PSOLOWST=$S('$G(PSOLOWER):$G(PSOLOWX),'$G(PSOLOWX):$G(PSOLOWER),$G(PSOLOWER)>$G(PSOLOWX):$G(PSOLOWX),$G(PSOLOWX)>$G(PSOLOWER):$G(PSOLOWER),$G(PSOLOWX)=$G(PSOLOWER):$G(PSOLOWER),1:0)
"RTN","PSOSIGDS",52,0)
 ;Q:'$G(PSOLOWST)
"RTN","PSOSIGDS",53,0)
 ;S PSQMIN=+$G(PSOLOWST)
"RTN","PSOSIGDS",54,0)
 S PSQMIN=$S($G(PSOLOWER):$G(PSOLOWER),1:0) ; PSQMIN=Minutes based in duration, or 0 if no duration
"RTN","PSOSIGDS",55,0)
 ;If Duration, determine using QTY how many days, regardless of duration, then use what is lower, that # of days or the duration, ROund that up, and check against Rx patient status
"RTN","PSOSIGDS",56,0)
 ;if no duration, just figure out using QTY # of days, then compare that against Rx patient status
"RTN","PSOSIGDS",57,0)
 S PSOZMIN=0
"RTN","PSOSIGDS",58,0)
 S PSOZMIN=PSOQX("QTY")/PSOQX("DOSE ORDERED",1)
"RTN","PSOSIGDS",59,0)
 S PSOZMIN=PSOZMIN*PSOFRQ
"RTN","PSOSIGDS",60,0)
 I $G(PSOLOWER) S PSOZMIN=$S(PSOLOWER<PSOZMIN:PSOLOWER,1:PSOZMIN)
"RTN","PSOSIGDS",61,0)
 S PSOZMIN=PSOZMIN/1440
"RTN","PSOSIGDS",62,0)
 ;S PSQMINZ=PSQMIN/PSOFRQ
"RTN","PSOSIGDS",63,0)
 ;S PSOQRND=PSQMINZ*+$G(PSOQX("DOSE ORDERED",1)) Q:'PSOQRND
"RTN","PSOSIGDS",64,0)
 D ROUND G QEND
"RTN","PSOSIGDS",65,0)
 Q
"RTN","PSOSIGDS",66,0)
COMP ;COMPLEX DOSE HERE
"RTN","PSOSIGDS",67,0)
 N PSQMNL,PSQMNLX,PSODUTOT,PSOLEFT,PSOZMIN,PSODUPTT,PSODUDIF,PSODUMIS,PSODUREP,PSQ1,PSODUX,PSODUXX,PSODSMIN,PSOFRQZ,PSOQUTOT
"RTN","PSOSIGDS",68,0)
 N PSOQLD,PSOQLDA,PSOQLDT,PSOQLDX
"RTN","PSOSIGDS",69,0)
 ;PSODUTOT = TOTAL OF ALL DURATIONS
"RTN","PSOSIGDS",70,0)
 ;PSODUPTT = TOTAL OF DISPENSE UNITS PER DOSE
"RTN","PSOSIGDS",71,0)
 ;PSODUDIF = DIFF. OF DURATION VS DAYS SUPPLY
"RTN","PSOSIGDS",72,0)
 ;PSOQUTOT=QTY
"RTN","PSOSIGDS",73,0)
 ;PSODUMIS = # OF SEQUENCES MISSING A DURATION IF >1 CAN'T DEFAULT
"RTN","PSOSIGDS",74,0)
 ;PSODUREP = SEQUENCE # THAT IS MISSING DURATION
"RTN","PSOSIGDS",75,0)
 ;PSODSMIN = MINUTES OF DAYS SUPPLY
"RTN","PSOSIGDS",76,0)
 S (PSODUTOT,PSODUDIF,PSODUMIS,PSODUREP,PSODSMIN,PSOQLDA,PSOQLDT,PSOQLDX)=0
"RTN","PSOSIGDS",77,0)
 ;next lines, add complex dose days supply calculation with ANDs
"RTN","PSOSIGDS",78,0)
 F PSOQLD=1:1:QDOSE S:$G(PSOQX("CONJUNCTION",PSOQLD))["A" PSOQLDA=1 S:$G(PSOQX("CONJUNCTION",PSOQLD))["T" PSOQLDT=1 S:$G(PSOQX("CONJUNCTION",PSOQLD))["X" PSOQLDX=1
"RTN","PSOSIGDS",79,0)
 I $G(PSOQLDA)!($G(PSOQLDX)) G QEND
"RTN","PSOSIGDS",80,0)
 S PSOQUTOT=+$G(PSOQX("QTY"))
"RTN","PSOSIGDS",81,0)
 F PSQ1=1:1:QDOSE D  Q:PSODUMIS>1
"RTN","PSOSIGDS",82,0)
 .I '$G(PSOQX("DURATION",PSQ1)) S PSODUMIS=PSODUMIS+1,PSODUREP=PSQ1 Q
"RTN","PSOSIGDS",83,0)
 G:PSODUMIS>1 QEND ; More than 1 sequence missing a duration
"RTN","PSOSIGDS",84,0)
 F PSQ=1:1:QDOSE D  Q:$G(PSQQUIT)
"RTN","PSOSIGDS",85,0)
 .I '$G(PSOQX("DOSE ORDERED",PSQ))!($G(PSOQX("SCHEDULE",PSQ))="") S PSQQUIT=1 Q
"RTN","PSOSIGDS",86,0)
 .S QTSH=$G(PSOQX("SCHEDULE",PSQ)) D QTS S:'$G(PSOFRQ) PSQQUIT=1 Q:$G(PSQQUIT)
"RTN","PSOSIGDS",87,0)
 .I $G(PSOQX("DURATION",PSQ)) S PSQMNL=$L(PSOQX("DURATION",PSQ)) D
"RTN","PSOSIGDS",88,0)
 ..S PSQMNLX=$S($E(PSOQX("DURATION",PSQ),PSQMNL)="M":1,$E(PSOQX("DURATION",PSQ),PSQMNL)="H":60,$E(PSOQX("DURATION",PSQ),PSQMNL)="S":.01666,$E(PSOQX("DURATION",PSQ),PSQMNL)="W":10080,$E(PSOQX("DURATION",PSQ),PSQMNL)="L":43200,1:1440)
"RTN","PSOSIGDS",89,0)
 ..S PSQMIN=PSQMNLX*(+$G(PSOQX("DURATION",PSQ)))
"RTN","PSOSIGDS",90,0)
 ..S PSODUTOT=PSODUTOT+(PSQMNLX*(+$G(PSOQX("DURATION",PSQ))))
"RTN","PSOSIGDS",91,0)
 .I '$G(PSOQX("DURATION",PSQ)) S PSOFRQZ=PSOFRQ Q
"RTN","PSOSIGDS",92,0)
 .S PSQMINZ=PSQMIN/PSOFRQ
"RTN","PSOSIGDS",93,0)
 .S PSODUPTT=$S($G(PSODUPTT):$G(PSODUPTT),1:0)+(PSQMINZ*+$G(PSOQX("DOSE ORDERED",PSQ)))
"RTN","PSOSIGDS",94,0)
 I $G(PSQQUIT) G QEND
"RTN","PSOSIGDS",95,0)
 I $G(PSOQUTOT)<0 G QEND
"RTN","PSOSIGDS",96,0)
 I '$G(PSODUMIS),$G(PSODUPTT)>$G(PSOQUTOT) G QEND
"RTN","PSOSIGDS",97,0)
 I '$G(PSODUMIS) S PSOZMIN=+$G(PSODUTOT)/1440 D ROUND G QEND
"RTN","PSOSIGDS",98,0)
 I PSODUPTT'<PSOQUTOT!('$G(PSOFRQZ)) G QEND
"RTN","PSOSIGDS",99,0)
 S PSODUPTT=PSOQUTOT-PSODUPTT S PSOLEFT=(PSODUPTT/+$G(PSOQX("DOSE ORDERED",PSODUREP)))*(+$G(PSOFRQZ))
"RTN","PSOSIGDS",100,0)
 S PSODUTOT=PSODUTOT+PSOLEFT S PSOZMIN=PSODUTOT/1440 D ROUND
"RTN","PSOSIGDS",101,0)
 G QEND
"RTN","PSOSIGDS",102,0)
QTS ;Find frequency
"RTN","PSOSIGDS",103,0)
 ;QTSH = SHCEDULE
"RTN","PSOSIGDS",104,0)
 ;either return PSOFRQ for frequency or PSSQUIT for no frequency
"RTN","PSOSIGDS",105,0)
 N SQTFLAG,SQQT,ZZQT,ZZQ,ZZQQ,ZQHOLD,QGLFLAG,PZQT,ZDL,ZZQX
"RTN","PSOSIGDS",106,0)
 K PSOFRQ
"RTN","PSOSIGDS",107,0)
 S (QGLFLAG,ZZQX)=0
"RTN","PSOSIGDS",108,0)
 I $G(QTSH)="" S PSQQUIT=1 Q
"RTN","PSOSIGDS",109,0)
 S SQTFLAG=0 F SQQT=0:0 S SQQT=$O(^PS(51.1,"B",QTSH,SQQT)) Q:'SQQT!($G(SQTFLAG))  I $P($G(^PS(51.1,SQQT,0)),"^",3) S PSOFRQ=$P($G(^(0)),"^",3),SQTFLAG=1
"RTN","PSOSIGDS",110,0)
 Q:SQTFLAG
"RTN","PSOSIGDS",111,0)
 F SQQT=0:0 S SQQT=$O(^PS(51,"B",QTSH,SQQT)) Q:'SQQT!($G(SQTFLAG))  I $P($G(^PS(51,SQQT,0)),"^",8) S PSOFRQ=$P($G(^(0)),"^",8),SQTFLAG=1
"RTN","PSOSIGDS",112,0)
 Q:SQTFLAG
"RTN","PSOSIGDS",113,0)
 S ZZQT=0 F ZZQ=1:1:$L(QTSH) S ZZQQ=$E(QTSH,ZZQ) I ZZQQ=" " S ZZQT=ZZQT+1
"RTN","PSOSIGDS",114,0)
 I 'ZZQT S PSQQUIT=1 Q
"RTN","PSOSIGDS",115,0)
 S ZZQT=ZZQT+1
"RTN","PSOSIGDS",116,0)
 K ZQHOLD S QGLFLAG=0 F PZQT=1:1:ZZQT S (ZDL,ZQHOLD)=$P(QTSH," ",PZQT) D
"RTN","PSOSIGDS",117,0)
 .Q:$G(ZDL)=""
"RTN","PSOSIGDS",118,0)
 .S ZZQX=0 F SQQT=0:0 S SQQT=$O(^PS(51.1,"B",ZDL,SQQT)) Q:'SQQT!($G(ZZQX))  I $P($G(^PS(51.1,SQQT,0)),"^",3) S PSOFRQ=$P($G(^(0)),"^",3),ZZQX=1,QGLFLAG=QGLFLAG+1
"RTN","PSOSIGDS",119,0)
 .Q:ZZQX
"RTN","PSOSIGDS",120,0)
 .S ZZQX=0 F SQQT=0:0 S SQQT=$O(^PS(51,"B",ZDL,SQQT)) Q:'SQQT!($G(ZZQX))  I $P($G(^PS(51,SQQT,0)),"^",8) S PSOFRQ=$P($G(^(0)),"^",8),ZZQX=1,QGLFLAG=QGLFLAG+1
"RTN","PSOSIGDS",121,0)
 I $G(QGLFLAG)>1 K PSOFRQ
"RTN","PSOSIGDS",122,0)
 I '$G(PSOFRQ) S PSQQUIT=1
"RTN","PSOSIGDS",123,0)
 Q
"RTN","PSOSIGDS",124,0)
QEND ;
"RTN","PSOSIGDS",125,0)
 K PSOFRQ
"RTN","PSOSIGDS",126,0)
 Q
"RTN","PSOSIGDS",127,0)
ROUND ;
"RTN","PSOSIGDS",128,0)
 Q:'$G(PSOZMIN)
"RTN","PSOSIGDS",129,0)
 I PSOZMIN'["." S PSOQX("DAYS SUPPLY")=PSOZMIN G RXP
"RTN","PSOSIGDS",130,0)
 S PSOQX("DAYS SUPPLY")=$P(PSOZMIN,".")+1
"RTN","PSOSIGDS",131,0)
RXP ;Compare against Rx Patient Status
"RTN","PSOSIGDS",132,0)
 Q:'$G(PSOQX("PATIENT"))
"RTN","PSOSIGDS",133,0)
 N PSO55,PSO553
"RTN","PSOSIGDS",134,0)
 S PSO55=$P($G(^PS(55,PSOQX("PATIENT"),"PS")),"^") I 'PSO55 G CLOZ
"RTN","PSOSIGDS",135,0)
 S PSO553=$P($G(^PS(53,PSO55,0)),"^",3) I 'PSO553 G CLOZ
"RTN","PSOSIGDS",136,0)
 I PSO553<$G(PSOQX("DAYS SUPPLY")) S PSOQX("DAYS SUPPLY")=PSO553
"RTN","PSOSIGDS",137,0)
CLOZ ;check for clozapine
"RTN","PSOSIGDS",138,0)
 N PSOCLPAT,PSOCLMAX
"RTN","PSOSIGDS",139,0)
 Q:'$G(PSOQX("DRUG"))
"RTN","PSOSIGDS",140,0)
 I $P($G(^PSDRUG(PSOQX("DRUG"),"CLOZ1")),"^")="PSOCLO1" D
"RTN","PSOSIGDS",141,0)
 .S PSOCLPAT=$O(^YSCL(603.01,"C",PSOQX("PATIENT"),0)) Q:'PSOCLPAT
"RTN","PSOSIGDS",142,0)
 .S PSOCLPAT=$P($G(^YSCL(603.01,PSOCLPAT,0)),"^",3)
"RTN","PSOSIGDS",143,0)
 .S PSOCLMAX=$S(PSOCLPAT="M":28,PSOCLPAT="B":14,PSOCLPAT="W":7,1:0)
"RTN","PSOSIGDS",144,0)
 .I PSOCLMAX,PSOCLMAX<$G(PSOQX("DAYS SUPPLY")) S PSOQX("DAYS SUPPLY")=PSOCLMAX
"RTN","PSOSIGDS",145,0)
 Q
"RTN","PSOSIGDS",146,0)
DAY(DATE) ;First 5 digits of FileMan date
"RTN","PSOSIGDS",147,0)
 N X
"RTN","PSOSIGDS",148,0)
 I DATE'?5N Q -1
"RTN","PSOSIGDS",149,0)
 S X=$E(DATE,4,5) I X<1!(X>12) Q -1
"RTN","PSOSIGDS",150,0)
 S X=DATE+1+(X=12*88)_"01"
"RTN","PSOSIGDS",151,0)
 Q $E($$FMADD^XLFDT(X,-1),6,7)
"RTN","PSOSIGDS",152,0)
 ;
"RTN","PSOSIGDS",153,0)
QTYX(PSOQX) ;
"RTN","PSOSIGDS",154,0)
 N PSOQLP,PSOQLN,PSOQAR,PSOCPRQT,QDOSE,QDOSEX S PSOCPRQT=1 F PSOQLP=0:0 S PSOQLP=$O(PSOQX("DURATION",PSOQLP)) Q:'PSOQLP  D
"RTN","PSOSIGDS",155,0)
 .S PSOQAR("DURATION",PSOQLP)=$G(PSOQX("DURATION",PSOQLP))
"RTN","PSOSIGDS",156,0)
 .I $E(PSOQX("DURATION",PSOQLP))?1A S PSOQLN=$L(PSOQX("DURATION",PSOQLP)) S PSOQX("DURATION",PSOQLP)=$E(PSOQX("DURATION",PSOQLP),2,PSOQLN)_$E(PSOQX("DURATION",PSOQLP))
"RTN","PSOSIGDS",157,0)
 S QDOSE=0 F QDOSEX=0:0 S QDOSEX=$O(PSOQX("DOSE ORDERED",QDOSEX)) Q:'QDOSEX  S QDOSE=QDOSE+1
"RTN","PSOSIGDS",158,0)
 D QTYCP
"RTN","PSOSIGDS",159,0)
 F PSOQLP=0:0 S PSOQLP=$O(PSOQAR("DURATION",PSOQLP)) Q:'PSOQLP  D
"RTN","PSOSIGDS",160,0)
 .S PSOQX("DURATION",PSOQLP)=$G(PSOQAR("DURATION",PSOQLP))
"RTN","PSOSIGDS",161,0)
 K PSOCPRQT
"RTN","PSOSIGDS",162,0)
 Q
"RTN","PSOSIGDS",163,0)
DSUP(PSOQX) ;Max Days Supply for CPRS, without QTY (just patient and drug)
"RTN","PSOSIGDS",164,0)
 ;Should we add to accept # of refills?
"RTN","PSOSIGDS",165,0)
 ;If no Drug, should we base on Orderable Item
"RTN","PSOSIGDS",166,0)
 N CS,DR,OI S CS=0,DR=$G(PSOQX("DRUG"))
"RTN","PSOSIGDS",167,0)
 I DR S CS=$$CSDS(DR)
"RTN","PSOSIGDS",168,0)
 I 'DR S OI=$G(PSOQX("OI")) D:OI
"RTN","PSOSIGDS",169,0)
 .N IDT,PAC S DR=0 F  S DR=$O(^PSDRUG("ASP",OI,DR)) Q:'DR!(CS)  D
"RTN","PSOSIGDS",170,0)
 ..S IDT=$P($G(^PSDRUG(DR,"I")),"^"),PAC=$P($G(^(2)),"^",3)
"RTN","PSOSIGDS",171,0)
 ..I IDT,IDT<DT Q
"RTN","PSOSIGDS",172,0)
 ..I PAC'["O" Q
"RTN","PSOSIGDS",173,0)
 ..S CS=$$CSDS(DR)
"RTN","PSOSIGDS",174,0)
 S PSOQX("DAYS SUPPLY")=$S(CS:30,1:90)
"RTN","PSOSIGDS",175,0)
 Q:'$G(PSOQX("PATIENT"))
"RTN","PSOSIGDS",176,0)
 N PSO55,PSO553
"RTN","PSOSIGDS",177,0)
 S PSO55=$P($G(^PS(55,PSOQX("PATIENT"),"PS")),"^") I 'PSO55 G DSUPDG
"RTN","PSOSIGDS",178,0)
 S PSO553=$P($G(^PS(53,PSO55,0)),"^",3) I 'PSO553 G DSUPDG
"RTN","PSOSIGDS",179,0)
 I PSO553<$G(PSOQX("DAYS SUPPLY")) S PSOQX("DAYS SUPPLY")=PSO553
"RTN","PSOSIGDS",180,0)
DSUPDG ;
"RTN","PSOSIGDS",181,0)
 N PSOCLPAT,PSOCLMAX
"RTN","PSOSIGDS",182,0)
 Q:'DR
"RTN","PSOSIGDS",183,0)
 I $P($G(^PSDRUG(DR,"CLOZ1")),"^")="PSOCLO1" D
"RTN","PSOSIGDS",184,0)
 .S PSOCLPAT=$O(^YSCL(603.01,"C",PSOQX("PATIENT"),0)) Q:'PSOCLPAT
"RTN","PSOSIGDS",185,0)
 .S PSOCLPAT=$P($G(^YSCL(603.01,PSOCLPAT,0)),"^",3)
"RTN","PSOSIGDS",186,0)
 .S PSOCLMAX=$S(PSOCLPAT="M":28,PSOCLPAT="B":14,$P($G(^(0)),"^",3)="W":7,1:0)
"RTN","PSOSIGDS",187,0)
 .I PSOCLMAX,PSOCLMAX<$G(PSOQX("DAYS SUPPLY")) S PSOQX("DAYS SUPPLY")=PSOCLMAX
"RTN","PSOSIGDS",188,0)
 Q
"RTN","PSOSIGDS",189,0)
MAX(PSOQX) ;
"RTN","PSOSIGDS",190,0)
 G EN^PSOSIGMX
"RTN","PSOSIGDS",191,0)
 Q
"RTN","PSOSIGDS",192,0)
 ;
"RTN","PSOSIGDS",193,0)
CSDS(DR) ;
"RTN","PSOSIGDS",194,0)
 Q:'DR 0
"RTN","PSOSIGDS",195,0)
 I $P($G(^PSDRUG(DR,"ND")),"^",3) S CS=+$P($G(^PSNDF(50.68,$P(^("ND"),"^",3),7)),"^")
"RTN","PSOSIGDS",196,0)
 E  S CS=$P($G(^PSDRUG(DR,0)),"^",3),CS=$S(CS[1:1,CS[2:2,CS[3:3,CS[4:4,CS[5:5,1:0)
"RTN","PSOSIGDS",197,0)
 I CS=1!(CS=2)!(CS=3)!(CS=4)!(CS=5) Q 1
"RTN","PSOSIGDS",198,0)
 Q 0
"RTN","PSOSIGDS",199,0)
 ;
"RTN","PSOVER")
0^12^B81192424^B75971956
"RTN","PSOVER",1,0)
PSOVER ;BIR/SAB - verify rx's by clerk ;07/03/95
"RTN","PSOVER",2,0)
 ;;7.0;OUTPATIENT PHARMACY;**16,21,27,117,131,146,251,375,387,379,391**;DEC 1997;Build 13
"RTN","PSOVER",3,0)
 ;External references L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
"RTN","PSOVER",4,0)
 ;External reference to ^PS(56 supported by DBIA 2229
"RTN","PSOVER",5,0)
 D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) W $C(7),!!,"Pharmacy Division Must be Selected!",! Q
"RTN","PSOVER",6,0)
 Q:'$D(^XUSEC("PSORPH",DUZ))  S PSOZVER=1
"RTN","PSOVER",7,0)
PAT K PSOTT,PSOACT,PSOVER,PSOQUIT,PSORX("DFLG"),DTOUT,DIRUT,PSOVQUIT W !! S DIC("A")="Enter PATIENT NAME (or ^C to verify for a clerk): ",DIC="^DPT(",DIC("S")="I $D(^PS(52.4,""C"",+Y))",DIC(0)="QEAMZ" D ^DIC K DIC G CLERK:$E(X,1,2)="^C",END:Y'>0
"RTN","PSOVER",8,0)
 S PSONV=0,(DFN,PSDFN,PSODFN)=+Y,PPL="",PSONAM=$P(^DPT(PSDFN,0),"^") D ^PSOBUILD
"RTN","PSOVER",9,0)
L1 D PID^VADPT S PSONV=$O(^PS(52.4,"C",PSDFN,PSONV)) I 'PSONV D:$$GET1^DIQ(52,PSONV,100,"I")'=13 PACK G PAT
"RTN","PSOVER",10,0)
 F DGDG=0:0 S DGDG=$O(^PS(52.4,"C",PSDFN,DGDG)) S PSONV=DGDG K PSOSIG,PSOTHER Q:'DGDG!($G(PSOQUIT))  D  Q:$G(DIRUT)
"RTN","PSOVER",11,0)
 .I $D(^PS(52.4,"ADI",DGDG,1)) S PSONV=DGDG D DGDGI Q
"RTN","PSOVER",12,0)
 .I $D(^PSRX(PSONV,"DRI")) S PSOSIG=1 D DGDGI Q
"RTN","PSOVER",13,0)
 .D:'$D(^PS(52.4,"ADI",PSONV,1))&('$D(^PSRX(PSONV,"DRI"))) DSPL Q
"RTN","PSOVER",14,0)
 G QUIT:$D(PSOSD)
"RTN","PSOVER",15,0)
 ;
"RTN","PSOVER",16,0)
SHOW I '$D(PSOSD) W !,$C(7),"This patient has no prescriptions on file",!! Q
"RTN","PSOVER",17,0)
 I ($Y+5)>IOSL D HD^PSODDPR2(5) Q:$G(PSODLQT)
"RTN","PSOVER",18,0)
 W !,$P(^DPT(DFN,0),"^"),?40,"ID#:"_VA("PID") W:$D(INT)!$D(PSONV) "  RX#: "_$S($D(INT):$P(INT,"^"),$D(^PSRX(PSONV)):$P(^PSRX(PSONV,0),"^"),1:"")
"RTN","PSOVER",19,0)
 D ^PSODSPL
"RTN","PSOVER",20,0)
SHOW2 ;
"RTN","PSOVER",21,0)
 I ($Y+5)>IOSL D HD^PSODDPR2() Q
"RTN","PSOVER",22,0)
 Q:$Y<5
"RTN","PSOVER",23,0)
 N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
"RTN","PSOVER",24,0)
 K DIR W ! S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
"RTN","PSOVER",25,0)
 W @IOF
"RTN","PSOVER",26,0)
 Q
"RTN","PSOVER",27,0)
 ;
"RTN","PSOVER",28,0)
CLERK D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) W $C(7),!!,"Pharmacy Division Must be Selected!",! G END
"RTN","PSOVER",29,0)
 K PSOVERPL,PSOVERPX,PSOVERPH,PSOVERLX,PSOVERQ,PSORX("DFLG"),DIRUT,DTOUT,PSOVQUIT
"RTN","PSOVER",30,0)
 K PSOQUIT,PSOCQ,PSOVORD,PSOINTV S PSOCLK=1 W ! S DIC="^VA(200,",DIC(0)="AEQM",DIC("S")="I $D(^PS(52.4,""D"",+Y))",DIC("A")="Enter Clerk Name: "
"RTN","PSOVER",31,0)
 D ^DIC K DIC K:Y'>0!($D(DTOUT)) PSORX G END:Y'>0!($D(DTOUT))
"RTN","PSOVER",32,0)
 S PSOTT=+Y,(PSONV,PSDFN0)=0,PPL="" K PSOVER,PSONAM
"RTN","PSOVER",33,0)
CL1 F DGDG=0:0 S DGDG=$O(^PS(52.4,"D",PSOTT,DGDG)) Q:'DGDG!($G(PSOQUIT))!($G(PSOCQ))  D  Q:$D(DIRUT)
"RTN","PSOVER",34,0)
 .S PSOVQUIT=0,(DFN,PSOVERPX,PSDFN,PSODFN)=$P(^PS(52.4,DGDG,0),"^",2),PSONV=DGDG D PATCHK K PSOSIG,PSOTHER
"RTN","PSOVER",35,0)
 .S CLFLAG=1 D STAT^PSODGDG2 K CLFLAG D:'$G(FLAGST)  Q:$D(DIRUT)
"RTN","PSOVER",36,0)
 ..S PSONVXX=PSONV I $G(PSOVERPH)=$G(PSOVERPX),$G(PSOVERLX) Q
"RTN","PSOVER",37,0)
 ..I $G(PSOVERPH)'=$G(PSOVERPX) K PSOVERLX D:$G(PSOVERPH)&('$G(PSOVERPL)) ULP S PSOVERPH=PSOVERPX D LPAT I $G(PSOVERPL) Q
"RTN","PSOVER",38,0)
 ..S PSDFN0=PSDFN D LRX I '$G(PSOMSG) Q
"RTN","PSOVER",39,0)
 ..K PSOMSG I $D(^PS(52.4,"ADI",DGDG,1)) S PSONV=DGDG D DSPL D PSOUL^PSSLOCK(PSONVXX) Q
"RTN","PSOVER",40,0)
 ..I $D(^PSRX(PSONV,"DRI")) S PSOSIG=1 D DSPL D PSOUL^PSSLOCK(PSONVXX) Q
"RTN","PSOVER",41,0)
 ..D:'$D(^PS(52.4,"ADI",PSONV,1))&('$D(^PSRX(PSONV,"DRI"))) DSPL D PSOUL^PSSLOCK(PSONVXX) Q
"RTN","PSOVER",42,0)
 D:$G(PSOVERPH)&('$G(PSOVERPL)) ULP
"RTN","PSOVER",43,0)
CL2 D:$$GET1^DIQ(52,PSONV,100,"I")'=13 PACK G CLERK
"RTN","PSOVER",44,0)
PATCHK I $D(PSOVER),PSDFN0,PSDFN0'=DFN S (DFN,PSDFN)=PSDFN0 D PACK S (DFN,PSDFN)=PSODFN D ^PSOBUILD,PID^VADPT S PSONAM=$P(^DPT(DFN,0),"^") Q
"RTN","PSOVER",45,0)
 I PSDFN0'=DFN D ^PSOBUILD,PID^VADPT S PSONAM=$P(^DPT(DFN,0),"^")
"RTN","PSOVER",46,0)
 Q
"RTN","PSOVER",47,0)
PACK Q:$$GET1^DIQ(52,PSONV,100,"I")=13  S PPL="" F J=0:0 S J=$O(PSOVER(J)) Q:'J  S PPL=PPL_J_","
"RTN","PSOVER",48,0)
 I PPL]"" S PSOOPT=3,PSOTRVV=1 D ^PSORXL K PSOOPT,PSOTRVV
"RTN","PSOVER",49,0)
 K PSD,PSOVER S PPL="" Q
"RTN","PSOVER",50,0)
QUIT D PACK
"RTN","PSOVER",51,0)
END K CAN,CLS,DA,DEA1,DEA2,DIC,DIE,DR,DRG,DRGG,DUP,DUPRX,DUPRX0,FLDT,I,ISDT,ISSD,J,LSTFL,PHYS,PPL,PSC,PSD,PSDFN,PSDFN0,PSDNEW,PSDOLD,PSMSG,PSOQUIT,PSOTT,PSOVER,PSREA,PSRFLS,PSRX,PSRX1,PSRX2,PSRXREF,PSVERFLG,RFLS,RX0,RX2,RX3,ST,ST0,STAR,X
"RTN","PSOVER",52,0)
 K D0,DQ,N,PHY,RFL,PSI,PSOTHER,PSS,PSOZVER,PI,PTST,SD,PSONAM,PSONULN,RFDATE,RFL1,RXF,Z,DRUG,II,RFLL,DRGX,DIPGM,PSOCNT,A1,C,ST00,FLAGST,STEXT,PSOCLK,PSOCQ,PSOVERPL,PSOVERPX,PSOVERPH,PSOVERLX,VERLFLAG,PSONVXX D KVA^VADPT
"RTN","PSOVER",53,0)
 K PSONOOR,PSOSIG,DIR,DUOUT,DTOUT,DIRUT,DIROUT,INA,MED,SER1,PSOVORD,PSOINTV,PSOVQUIT,PSVFLAG ;K:'$G(POERR) PSOSD
"RTN","PSOVER",54,0)
 Q
"RTN","PSOVER",55,0)
DSPL ;
"RTN","PSOVER",56,0)
 Q:$P(^PSRX(PSONV,"STA"),"^")=13
"RTN","PSOVER",57,0)
 S DA=PSONV
"RTN","PSOVER",58,0)
 S PSVFLAG=1 D ^PSOVER1 I $G(PSORX("DFLG")) K PSVFLAG
"RTN","PSOVER",59,0)
 Q
"RTN","PSOVER",60,0)
DGDGI ;process drug interaction for non verified rxs
"RTN","PSOVER",61,0)
 K DIRUT,DTOUT,PSORX("DFLG")
"RTN","PSOVER",62,0)
 S SER1=$S('$G(PSOSIG):$P(^PS(52.4,PSONV,0),"^",9),1:$P(^PSRX(PSONV,"DRI"),"^")),PSVFLAG=1
"RTN","PSOVER",63,0)
 S MED=$S('$G(PSOSIG):$P(^PS(52.4,PSONV,0),"^",10),1:$P(^PSRX(PSONV,"DRI"),"^",2))
"RTN","PSOVER",64,0)
 K LOCKARRY,PSOVMSGX S VERLFLAG=0 I $G(MED) F LOCKINA=1:1 S PSOLKVRX=$P(MED,",",LOCKINA) Q:$G(PSOLKVRX)=""!($G(VERLFLAG))  D LK1
"RTN","PSOVER",65,0)
 K PSOVMSGX
"RTN","PSOVER",66,0)
 S PSVERFLG=0,IFN=PSONV,INT=^PSRX(IFN,0) N PSOOLDFN S PSOOLDFN=DFN
"RTN","PSOVER",67,0)
 F INA=1:1 S PSODFN=DFN Q:$P(SER1,",",INA)=""!($G(MED)="")  D  Q:$G(PSOVQUIT)!$G(PSORX("DFLG"))
"RTN","PSOVER",68,0)
 .I $P(SER1,",",INA) S SER=^PS(56,$P(SER1,",",INA),0)
"RTN","PSOVER",69,0)
 .E  S $P(SER,"^",4)=$S($P(SER1,",",INA)="Critical":1,1:2)
"RTN","PSOVER",70,0)
 .S RX=^PSRX(PSONV,0),STA=+$G(^("STA")),$P(RX,"^",15)=STA,PSOOPT=1
"RTN","PSOVER",71,0)
 .W !!!,$P(^DPT(DFN,0),"^"),?39,"ID#: ",$E($P(^(0),"^",9),1,3)_"-"_$E($P(^(0),"^",9),4,5)_"-"_$E($P(^(0),"^",9),6,9),?57,"RX: ",$P(^PSRX(PSONV,0),"^")
"RTN","PSOVER",72,0)
 .I STA'=13 D FULL^VALM1 D ^PSOVER1  S:'$G(DFN) DFN=PSOOLDFN
"RTN","PSOVER",73,0)
 Q:$G(PSORX("DFLG"))  Q:$G(DIRUT)!($G(DTOUT))
"RTN","PSOVER",74,0)
 I '$G(PSVERFLG),$P(^PSRX(PSONV,"STA"),"^")=4!($P(^("STA"),"^")=1) S $P(^PSRX(PSONV,"STA"),"^")=1 D DSPL G DONE
"RTN","PSOVER",75,0)
 I '$D(^PS(52.4,"ADI",PSONV,1)),$P(^PSRX(PSONV,"STA"),"^")=1 D DSPL G DONEX:$G(DIRUT)!($G(DTOUT)) G DONE
"RTN","PSOVER",76,0)
DONE K PSOVORD I $P(^PSRX(PSONV,"STA"),"^")'=1,$P(^("STA"),"^")'=4 K ^PSRX(PSONV,"DRI")
"RTN","PSOVER",77,0)
 S PSOTHER="" F  S PSOTHER=$O(PSOTHER(PSOTHER)) Q:PSOTHER=""  D
"RTN","PSOVER",78,0)
 .I $G(PSOTHER),$P($G(^PSRX(PSOTHER,"STA")),"^")=1,$P($G(^PS(52.4,PSOTHER,0)),"^",10)="" S PSONV=PSOTHER D DSPL
"RTN","PSOVER",79,0)
 D:$D(LOCKARRY) ULK1
"RTN","PSOVER",80,0)
DONEX K PSOOPT,SER,LOCKARRY,LOCKINA,PSOLKVRX,DTOUT,DIRUT,PSORX("DFLG")
"RTN","PSOVER",81,0)
 Q
"RTN","PSOVER",82,0)
OERR ;
"RTN","PSOVER",83,0)
 N PSOEDITF,PSOVEDIT,PSOOORN,XQORNOD,Y,PSOVBCK S PSOVEDIT=0
"RTN","PSOVER",84,0)
 K PSONOOR,PSODLQT,PSOVER,PSVERFLG,PSOVORD,PSOSIG I $G(PSONACT) W $C(7),$C(7) S VALMSG="No Pharmacy Orderable Item!",VALMBCK="" Q
"RTN","PSOVER",85,0)
 I $G(PSOTPBFG) N PSOTPPEN,PSOTPPEX,PSOTPPE9 S PSOTPPEN=$P(PSOLST($P(PSLST,",",ORD)),"^",2),PSOTPPEX=0,PSOTPPE9=1 D VOPN^PSOTPCAN I PSOTPPEX S VALMBCK="" K PSOTPPEN,PSOTPPEX,PSOTPPE9 Q
"RTN","PSOVER",86,0)
 K PSOTPPEN,PSOTPPEX,PSOTPPE9,PSORX("DFLG")
"RTN","PSOVER",87,0)
 I $G(PSOBEDT) W $C(7),$C(7) S VALMSG="Invalid Action at this time !",VALMBCK="" Q
"RTN","PSOVER",88,0)
 I '$D(^PSRX(+$P(PSOLST($P(PSLST,",",ORD)),"^",2),"PKI")),'$D(^XUSEC("PSORPH",DUZ)) S VALMSG="Unauthorized Action!",VALMBCK="" Q
"RTN","PSOVER",89,0)
 I $D(^PSRX(+$P(PSOLST($P(PSLST,",",ORD)),"^",2),"PKI")) N FL S FL=0 D  I FL Q
"RTN","PSOVER",90,0)
 .I $P($G(^PSRX(+$P(PSOLST($P(PSLST,",",ORD)),"^",2),"PKI")),"^"),'$D(^XUSEC("PSDRPH",DUZ)) S VALMSG="Digitally Signed Order - PSDRPH key required",VALMBCK="",FL=1 Q
"RTN","PSOVER",91,0)
 .I $P($G(^PSRX(+$P(PSOLST($P(PSLST,",",ORD)),"^",2),"PKI")),"^",2),'$D(^XUSEC("PSDRPH",DUZ)) S VALMSG="CS Order - PSDRPH key is required",VALMBCK="",FL=1 Q
"RTN","PSOVER",92,0)
 S PSOVRXN=$P(PSOLST($P(PSLST,",",ORD)),"^",2),PSOVDFN=$P($G(^PSRX(PSOVRXN,0)),"^",2)
"RTN","PSOVER",93,0)
 S PSOPLCK=$$L^PSSLOCK(PSOVDFN,0) I '$G(PSOPLCK) S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is editing orders for this patient.") S VALMBCK="" K PSOPLCK Q
"RTN","PSOVER",94,0)
 K PSOPLCK D PSOL^PSSLOCK(PSOVRXN) I '$G(PSOMSG) D UL^PSSLOCK(PSOVDFN) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order.") K PSOMSG S VALMBCK="" Q
"RTN","PSOVER",95,0)
 N PSODFN S (PSOZVER,PSLSTVER)=1
"RTN","PSOVER",96,0)
 D FULL^VALM1 S (PSONV,X,DA)=$P(PSOLST($P(PSLST,",",ORD)),"^",2) K DIC S DIC(0)="NZ",DIC=52.4 D ^DIC K DIC I Y<1 D  D:'$G(PSLSTVER) ULB Q:'$G(PSLSTVER)
"RTN","PSOVER",97,0)
 .I $P($G(^PSRX(+PSONV,"STA")),"^")'=1,$P($G(^("STA")),"^")'=4 K PSONV,DA,X,Y,PSOZVER,PSLSTVER S VALMSG="Invalid Action Selection!",VALMBCK="" Q
"RTN","PSOVER",98,0)
 .S PSLSTVER=2
"RTN","PSOVER",99,0)
 .S DIC="^PS(52.4,",DLAYGO=52.4,(DINUM,X)=PSONV,DIC(0)="L" K DD,DO D FILE^DICN K DD,DO,DIC,DINUM,DLAYGO
"RTN","PSOVER",100,0)
 .S ^PS(52.4,PSONV,0)=PSONV_"^"_$P(^PSRX(PSONV,0),"^",2)_"^"_+$P(^(0),"^",16)_"^^"_$E($P($G(^(2)),"^"),1,7)_"^"_PSONV_"^"_$E($P($G(^(2)),"^",6),1,7)
"RTN","PSOVER",101,0)
 .S DIK="^PS(52.4,",DA=PSONV D IX^DIK K DIK S Y(0)=^PS(52.4,PSONV,0),(X,DA)=PSONV
"RTN","PSOVER",102,0)
 D STAT^PSODGDG2 G:FLAGST EOJ
"RTN","PSOVER",103,0)
 N LST S (DFN,PSDFN,PSODFN)=$P(^PSRX(PSONV,0),"^",2),PPL="",PSONAM=$P(^DPT(PSDFN,0),"^")
"RTN","PSOVER",104,0)
 D PID^VADPT S PSOVORD=PSONV
"RTN","PSOVER",105,0)
 I $D(^PS(52.4,"ADI",PSONV,1)) D DGDGI G:$G(PSOVQUIT)!$G(PSORX("DFLG")) EOJ G PPL
"RTN","PSOVER",106,0)
 I $D(^PSRX(PSONV,"DRI")) S PSOSIG=1 D DGDGI G:$G(PSOVQUIT)!$G(PSORX("DFLG")) EOJ G PPL
"RTN","PSOVER",107,0)
 G:$G(PSORX("DFLG")) EOJ D DSPL
"RTN","PSOVER",108,0)
PPL I $G(PSLSTVER)=2,$D(^PS(52.4,PSONV,0)) S DA=PSONV,DIK="^PS(52.4," D ^DIK K DIK,DA
"RTN","PSOVER",109,0)
 G EOJ:'$O(PSOVER(0))
"RTN","PSOVER",110,0)
 S PSONVLP="" F  S PSONVLP=$O(PSOVER(PSONVLP)) Q:PSONVLP=""  D
"RTN","PSOVER",111,0)
 .D MARKV^PSOTPCAN
"RTN","PSOVER",112,0)
 .I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=PSONVLP_"," Q
"RTN","PSOVER",113,0)
 .F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1  S PSOX2=PSOX1
"RTN","PSOVER",114,0)
 .I $L(PSORX("PSOL",PSOX2))+$L(PSONVLP)<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_PSONVLP_","
"RTN","PSOVER",115,0)
 .E  S PSORX("PSOL",PSOX2+1)=PSONVLP_","
"RTN","PSOVER",116,0)
EOJ D ULB,END
"RTN","PSOVER",117,0)
 K D,DGDG,MW,PSONVLP,P,PCOMX,PDA,PSPRXN,RX,PSD,PSOSTA,PSLSTVER,PSOVORD,PSVFLAG
"RTN","PSOVER",118,0)
 I $G(PSOCLK),$G(PSLST) K PSLST
"RTN","PSOVER",119,0)
 I $G(PSOCLK)!($G(PSOPOCK)) D FULL^VALM1 K VALMBCK D ^PSOBUILD,BLD^PSOORUT1 S Y=0 F  S Y=$O(PSOLST(Y)) Q:Y=""  I $P(PSOLST(Y),"^",2)=PSONV S PSLST=","_Y Q
"RTN","PSOVER",120,0)
 I $G(^PSRX(PSONV,"STA"))'=1&($G(^PSRX(PSONV,"STA"))'=4) S VALMBCK="Q" G EOJ2
"RTN","PSOVER",121,0)
 I '$G(PSOCLK)!('$G(PSOPOCK)) S VALMBCK="R" S:$G(PSOVBCK) VALMBCK="Q"
"RTN","PSOVER",122,0)
EOJ2 ;
"RTN","PSOVER",123,0)
 K PSONV,Y
"RTN","PSOVER",124,0)
 L -^PSRX($P(PSOLST(ORN),"^",2))
"RTN","PSOVER",125,0)
 Q
"RTN","PSOVER",126,0)
LPAT ;
"RTN","PSOVER",127,0)
 K PSOVERPL
"RTN","PSOVER",128,0)
 I '$G(PSOVERPX) Q
"RTN","PSOVER",129,0)
 S PSOPLCK=$$L^PSSLOCK(PSOVERPX,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S (PSOVERPL,PSOVERLX)=1
"RTN","PSOVER",130,0)
 K PSOPLCK
"RTN","PSOVER",131,0)
 Q
"RTN","PSOVER",132,0)
ULP ;
"RTN","PSOVER",133,0)
 I '$G(PSOVERPH) Q
"RTN","PSOVER",134,0)
 D UL^PSSLOCK(PSOVERPH) K PSOVERPH
"RTN","PSOVER",135,0)
 Q
"RTN","PSOVER",136,0)
LRX ;
"RTN","PSOVER",137,0)
 K PSOMSG I '$G(PSONV) Q
"RTN","PSOVER",138,0)
 D PSOL^PSSLOCK(PSONV) I '$G(PSOMSG) W !!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),! D  K DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to Continue" D ^DIR K DIR
"RTN","PSOVER",139,0)
 .I $G(PSDFN) W "for patient "_$P($G(^DPT(PSDFN,0)),"^")_".",!
"RTN","PSOVER",140,0)
 Q
"RTN","PSOVER",141,0)
ULRX ;
"RTN","PSOVER",142,0)
 I '$G(PSONV) Q
"RTN","PSOVER",143,0)
 D PSOUL^PSSLOCK(PSONV)
"RTN","PSOVER",144,0)
 Q
"RTN","PSOVER",145,0)
LK1 ;
"RTN","PSOVER",146,0)
 I '$G(PSOLKVRX) Q
"RTN","PSOVER",147,0)
 D PSOL^PSSLOCK(PSOLKVRX) I '$G(PSOMSG) S VERLFLAG=1,PSOVMSGX=$P($G(PSOMSG),"^",2) Q
"RTN","PSOVER",148,0)
 S LOCKARRY(PSOLKVRX)=PSOLKVRX
"RTN","PSOVER",149,0)
 Q
"RTN","PSOVER",150,0)
ULK1 ;
"RTN","PSOVER",151,0)
 I '$D(LOCKARRY) Q
"RTN","PSOVER",152,0)
 S PSOVOLK="" F  S PSOVOLK=$O(LOCKARRY(PSOVOLK)) Q:$G(PSOVOLK)=""  D PSOUL^PSSLOCK(PSOVOLK)
"RTN","PSOVER",153,0)
 K PSOVOLK
"RTN","PSOVER",154,0)
 Q
"RTN","PSOVER",155,0)
ULB ;
"RTN","PSOVER",156,0)
 I $G(PSOVDFN) D UL^PSSLOCK(PSOVDFN)
"RTN","PSOVER",157,0)
 I $G(PSOVRXN) D PSOUL^PSSLOCK(PSOVRXN)
"RTN","PSOVER",158,0)
 K PSOVDFN,PSOVRXN
"RTN","PSOVER",159,0)
 Q
"UP",52.41,52.44,-1)
52.41^9
"UP",52.41,52.44,0)
52.44
"VER")
8.0^22.0
"^DD",52,52,311,0)
BACKDOOR SIGNATURE STATUS^S^1:YES;0:NO;^PKI;2^Q
"^DD",52,52,311,3)
Was the order entered via backdoor?
"^DD",52,52,311,21,0)
^^2^2^3120918^
"^DD",52,52,311,21,1,0)
This field indicates whether a controlled substance order, schedule (I-V),
"^DD",52,52,311,21,2,0)
was not digitally signed but entered via backdoor.
"^DD",52,52,311,"DT")
3120918
"^DD",52.41,52.41,118,0)
DRUG INCLUDED^S^1:YES;0:NO;^0;25^Q
"^DD",52.41,52.41,118,3)
Is the dispense drug included in the hash check?
"^DD",52.41,52.41,118,21,0)
^^2^2^3120928^
"^DD",52.41,52.41,118,21,1,0)
This field indicates CPRS included the dispense drug as part of the hash
"^DD",52.41,52.41,118,21,2,0)
calculation for digitally signed orders.
"^DD",52.41,52.41,118,23,0)
^^2^2^3120928^
"^DD",52.41,52.41,118,23,1,0)
A value of 1 indicates CPRS did include the dispense drug as part of the
"^DD",52.41,52.41,118,23,2,0)
hash calculation for digitally signed orders.
"^DD",52.41,52.41,118,"DT")
3120928
"^DD",52.41,52.41,120,0)
DIRECTIONS FOR USE^52.44A^^9;0
"^DD",52.41,52.41,120,21,0)
^^1^1^3120919^
"^DD",52.41,52.41,120,21,1,0)
This multiple contains the raw HL7 dosage data as sent from CPRS.
"^DD",52.41,52.44,0)
DIRECTIONS FOR USE SUB-FIELD^^.01^1
"^DD",52.41,52.44,0,"DT")
3120914
"^DD",52.41,52.44,0,"NM","DIRECTIONS FOR USE")

"^DD",52.41,52.44,0,"UP")
52.41
"^DD",52.41,52.44,.01,0)
DIRECTIONS FOR USE^F^^0;1^K:$L(X)>250!($L(X)<1) X
"^DD",52.41,52.44,.01,1,0)
^.1^^0
"^DD",52.41,52.44,.01,3)
Answer must be 1-250 characters in length.
"^DD",52.41,52.44,.01,21,0)
^^3^3^3120919^^
"^DD",52.41,52.44,.01,21,1,0)
This field contains the raw HL7 dosage data as sent from CPRS and will be 
"^DD",52.41,52.44,.01,21,2,0)
used to validate the integrity (hash count) against the CPRS digitally
"^DD",52.41,52.44,.01,21,3,0)
signed orders.
"^DD",52.41,52.44,.01,"DT")
3120919
**END**
**END**