                   V. A.  C R O S S  R E F E R E N C E R  7.3
                       [2008 VA Standards & Conventions]
                  UCI: VISTA CPU: ROU    Jun 01, 2016@09:50:20

The BUILD file Data Dictionaries are being processed.

53.8 CLOZAPINE MEDICATION OVERRIDES.......
The option and function files are being processed.


Routines are being processed.
Routines: 14  Faux Routines: 2

PSGOE41   PSGOE42   PSGOE7    PSGOE8    PSGOE81   PSGOE82   PSGOE92   PSGOER    
PSGOER0   PSGOEV    PSJCLOLS  PSJCLOZ   PSJOE     PSJRXLAB  

          Data Dictionaries
|dd53.8        |opt           

--- CROSS REFERENCING ---

   Press return to continue:

Compiled list of Errors and Warnings              Jun 01, 2016@09:50:20 page 1
No errors or warnings to report


--- Routine Detail   --- with REGULAR ROUTINE LISTING ---
   Press return to continue:

PSGOE41  * *  121 Lines,  6546 Bytes, Checksum: B37515595
                                                  Jun 01, 2016@09:50:20 page 2
              883 bytes in comments
PSGOE41  ;BIR/CML3-REGULAR ORDER ENTRY (CONT.) ;09 JAN 97 / 9:13 AM 
         ;;5.0;INPATIENT MEDICATIONS;**50,63,64,69,58,111,136,113,267,327**;16 D
          EC 97;Build 158
         ;
         ; Reference to ^DICN is supported by DBIA 10009.
         ; Reference to %DT is supported by DBIA 10003.
         ; Reference to %DTC is supported by DBIA 10000.
         ; Reference to ^PS(51.1 is supported by DBIA 2177.
         ;
39       ; admin times
         G:$P(PSGNEDFD,"^",3)="P"!($P(PSGNEDFD,"^",3)="OC") 8
         I $$ODD^PSGS0(PSGS0XT) G 8
         W !,"ADMIN TIMES: "_$S(PSGS0Y:PSGS0Y_"// ",1:"") R X:DTIME I X="^"!'$T 
          W:'$T $C(7) S PSGOROE1=1 G DONE
         I X="",PSGS0Y]"" S X=PSGS0Y
         I X="",$G(PSGS0XT)="D" I $L(PSGSCH,"@")=2,$P(PSGSCH,"@",2) S (PSGAT,PSG
          S0Y)=$P(PSGSCH,"@",2) G 8
         I X?1."?" D ENHLP^PSGOEM(53.1,39) G 39
         I X="@" D DEL G:%'=1 39 S (PSGFOK(39),PSGS0Y)="" G 39
         S PSGF2=39 I $E(X)="^" D FF G:Y>0 @Y G 39
         I (PSGS0XT="D")&('$G(X)!(X["@"&($P($G(X),"@",2)))) I ((",P,R,")'[(","_$
          G(PSGST)_",")) D  G 39
         . W $C(7),"  ??" S X="?" W !,"This is a 'DAY OF THE WEEK' schedule and 
          MUST have admin times." D ENHLP^PSGOEM(53.1,39)
         I $G(PSGS0XT)'="D",$G(PSGS0XT)'="P",$G(PSGS0XT)'="OC" D TIMES I '$D(X) 
          G 39
         I $G(PSGS0XT)="O",X="" S (PSGAT,PSGS0Y)=X,PSGFOK(39)="" G 8
         D ENCHK^PSGS0 I '$D(X) W $C(7),"  ??" G 39
         S (PSGAT,PSGS0Y)=X,PSGFOK(39)=""
         ;
8        ; special instructions
         S PSGSI=$$EDITSI^PSJBCMA5($G(PSGP),$G(PSGORD))
         S PSGF2=8 I $E(X)="^" D FF G:Y>0 @Y G 8
         I X="@",PSGSI="" W $C(7),"  ??" S X="?" D ENHLP^PSGOEM(53.1,8) G 8
         I X="@" D DEL G:%'=1 8 S (PSGFOK(8),PSGSI)="" G:'$G(PSGOE3) 10
         I X?1."?" D ENHLP^PSGOEM(53.1,8) G 8
         S PSGSI=$S((PSGSI>0&(PSGSI<3)):$G(^PS(53.45,+PSJSYSP,5,1,0))_" "_$G(^PS
          (53.45,+PSJSYSP,5,2,0)),PSGSI>2:"Instructions too long. See Order View
           or BCMA for full text",1:"")
         I PSGSI]"" S PSGSI=$$ENBCMA^PSJUTL("U"),PSGFOK(8)=""
         Q:$G(PSGOE3)
10       ; start date/time
         D ^PSGNE3
         S:'$D(PSGNESDO) PSGNESDO=$$ENDD^PSGMI(PSGNESD) S PSGSD=PSGNESDO
A10      W !,"START DATE/TIME: "_PSGSD_"// " R X:DTIME I X="^"!'$T W:'$T $C(7) S
           PSGOROE1=1 G DONE
         I X="",PSGNESD W "  "_PSGSD G O25
         I X="P" D ENPREV^PSGDL W:'$D(X) $C(7) G:'$D(X) A10 S PSGNESD=+X,PSGSD=$
          $ENDD^PSGMI(+X) W "  ",PSGSD G O25
         S PSGF2=10 I X="@"!(X?1."?") W:X="@" $C(7),"  (Required)" S:X="@" X="?"
           D ENHLP^PSGOEM(53.1,10)
         I $E(X)="^" D FF G:Y>0 @Y G A10
         NEW TMPX S TMPX=X,X1=PSGDT,X2=-7 D C^%DTC K %DT S %DT="ERTX",%DT(0)=X,X
          =TMPX D ^%DT K %DT I Y'>0 D ENHLP^PSGOEM(53.1,10) G A10
         S PSGNESD=+Y,PSGSD=$$ENDD^PSGMI(+Y),(PSGNEFD,PSGFD)=""
         ;
O25      ;
         S PSGFOK(10)="" I $P(PSGNEDFD,"^",3)="O" S PSGNEFD=$$ENOSD^PSJDCU(PSJSY
          SW0,PSGNESD,PSGP) I PSGNEFD]"" S PSGFD=$$ENDD^PSGMI(PSGNEFD)
         ;
25       ; stop date
         Q:$G(PSGOE3)
         I 'PSGNEFD D ENFD^PSGNE3(PSGDT) S PSGFD=PSGNEFDO
         ;/RBN-RJS Begin changes for emergency registration of clozapine patient
           Set end date to start date + 4 days at midnight.
         I $G(^TMP("CLOZFLG",DFN)) D
         .N X,X1,X2,X3 S X3=$P(PSGNESD,".",1)_".2359",X1=X3,X2=4 D C^%DTC S PSGN
          EFD=X,PSGFD=$$ENDD^PSGMI(PSGNEFD)
         .S PSGCFLG=0,PSGOLDED=PSGFD,PSGNEFDOLD=PSGNEFD
         I $D(CLOZPAT),'$G(^TMP("CLOZFLG",DFN)) D
         .N X,X1,X2
         .S X1=PSGNESD,X2=$S($G(CLOZPAT)=2:28,$G(CLOZPAT)=1:14,$G(CLOZPAT)=0:7,1
          :90) D C^%DTC S PSGNEFD=X,PSGFD=$$ENDD^PSGMI(PSGNEFD)
         .S PSGCFLG=0,PSGOLDED=PSGFD,PSGNEFDOLD=PSGNEFD
         ;/RBN-RJS End changes for emergency registration of clozapine patient
A25      W !,"STOP DATE/TIME: "_$S(PSGFD]"":PSGFD_"// ",1:"") R X:DTIME I X="^"!
          '$T W:'$T $C(7) S PSGOROE1=1 G DONE
         I X="",PSGNEFD W "   "_PSGFD S PSGFOK(25)=""  G W25
         S PSGF2=25 I $E(X)="^" D FF G:Y>0 @Y G A25
         I X="@"!(X?1."?") W:X="@" $C(7),"  (Required)" S:X="@" X="?" D ENHLP^PS
          GOEM(53.1,25)
         I X=+X,(X>0),(X'>2000000) G A25:'$$ENDL^PSGDL(PSGSCH,X) K PSGDLS S PSGD
          L=X W " ...dose limit..." D EN1^PSGDL
         K %DT S %DT="ERTX",%DT(0)=PSGNESD D ^%DT K %DT G:Y'>0 A25 S PSGNEFD=+Y,
          PSGFD=$$ENDD^PSGMI(+Y),PSGFOK(25)=""
         ;/RJS Begin changes for emergency registration of clozapine patient Set
           end date to start date + 4 days at midnight.
         I $D(CLOZPAT),'$G(^TMP("CLOZFLG",DFN)) D
         .N X1,X2
         .S X1=PSGNESD,X2=$S($G(CLOZPAT)=2:28,$G(CLOZPAT)=1:14,$G(CLOZPAT)=0:7,1
          :90)
         .I $P(PSGNEFD,".",1)-$P(PSGNESD,".",1)'=X2 S PSGCFLG=1,PSGFD=PSGOLDED,P
          SGNEFD=PSGNEFDOLD W !!,"*** STOP DATE/TIME NOT TO EXCEED "_X2_" DAYS! 
          ***",!
         G:$G(PSGFLG) A25
         ;.D C^%DTC S PSGNEFD=X,PSGFD=$$ENDD^PSGMI(PSGNEFD)
         I $G(^TMP("CLOZFLG",DFN)) D  G:X>4 A25
         .S X1=+Y,X2=PSGNESD D ^%DTC
         .Q:X'>4
         .I X>4 D
         ..W !!?13,"*** EMERGENCY SUPPLY NOT TO EXCEED 4 DAYS! ***",!
         ..N X,X1,X2,X3 S X3=$P(PSGNESD,".",1)_".2359",X1=X3,X2=4 D C^%DTC S PSG
          NEFD=X
         ..S PSGFD=$$ENDD^PSGMI(PSGNEFD)
         ;/RJS End changes for emergency registration of clozapine patient
W25      ;
         N Z
         D DOSE I $G(Z)]"",Z>PSGNEFD D  G A25
         . W !,"There must be an admin time that falls between the Start Date/Ti
          me"
         . W !,"and the Stop Date/Time."
         I PSGNEFD<PSGDT W $C(7),!!?13,"*** WARNING! THE STOP DATE ENTERED IS IN
           THE PAST! ***",!
         D EFDNEW^PSJUTL  ;Display Expected First Dose;BHW;PSJ*5*136
NEXT     ;
         G 1^PSGOE42
         ;
DONE     ;
         I PSGOROE1 K Y W $C(7),"  ...order not entered..."
         K F,F0,F1,PSGF2,F3,PSG,SDT,PSGCFLG Q
         ;
FF       ; up-arrow to another field
         D ENFF^PSGOEM I Y>0,Y'=39,Y'=8,Y'=10,Y'=25 S Y=Y_"^PSGOE4"_$S("^109^13^
          3^7^26^"[("^"_Y_"^"):"",1:2) S:$P(Y,U)=2 FB=PSGF2_"^PSGOE41"
         Q
         ;
DEL      ; delete entry
         W !?3,"SURE YOU WANT TO DELETE" S %=0 D YN^DICN I %'=1 W $C(7),"  <NOTH
          ING DELETED>"
         Q
TIMES       ;At least one admin time, not more than interval allows.
         I $G(PSGS0XT)'="O",X="" W !,"This order requires at least one administr
          ation time." K X Q  ;No times
         N H,I,MAX
         I PSGSCH]"" I $D(^PS(51.1,"AC","PSJ",PSGSCH)) S H=+$O(^PS(51.1,"AC","PS
          J",PSGSCH,0)) S I=$P($G(^PS(51.1,H,0)),"^",3)
         I $G(PSGST)="O",$L(X,"-")>1 W !,"This is a One Time Order - only one ad
          min time is permitted." K X Q
         I $G(PSGST)="O" Q  ;Done validating One Time
         I +$G(I)=0 Q  ;No frequency - can not check frequency related items
         S MAX=1440/I
         I MAX<1 D  Q
         . I $L(X,"-")'=1 W !,"This order requires one admin time." K X Q
         I MAX'<1,$L(X,"-")>MAX W !,"The number of admin times entered is greate
          r than indicated by the schedule." K X Q  ;Too many times
         I MAX'<1,$L(X,"-")<MAX W !,"The number of admin times entered is fewer 
          than indicated by the schedule."  ;Too few times
         Q
DOSE     ;Make certain at least one dose is given.
         Q:$G(PSGST)="OC"!($G(PSGST)="P")
         N INFO,X
         S Z="",INFO=($G(PSGNESD))_U_($G(PSGNEFD))_U_($G(PSGSCH))_U_($G(PSGST))_
          U_($G(PSGDRG))_U_($G(PSGS0Y))
         I '$L($G(PSGP)) N PSGP S PSGP=""
         S Z=$$ENQ^PSJORP2(PSGP,INFO)  ;Expected first dose.
         Q

*****   INDEX OF PSGOE41   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
>> %            39+7,8+4,DEL+1*
   %DT          A10+5!*,A25+5!*
   %DT(0        A10+5*,A25+5*
>> CLOZPAT      25+7,25+9,A25+7,A25+9
>> DFN          25+4,25+7,A25+7,A25+13
   DTIME        39+3,A10,A25
   F            DONE+2!
   F0           DONE+2!
   F1           DONE+2!
   F3           DONE+2!
>> FB           FF+1*
   H            TIMES+2~,TIMES+3*
   I            TIMES+2~,TIMES+3*,TIMES+6,TIMES+7
   INFO         DOSE+2~,DOSE+3*,DOSE+5
   MAX          TIMES+2~,TIMES+7*,TIMES+8,TIMES+10,TIMES+11
   PSG          DONE+2!
>> PSGAT        39+5*,39+12*,39+14*
   PSGCFLG      25+6*,25+10*,A25+10*,DONE+2!
>> PSGDL        A25+4*
   PSGDLS       A25+4!
>> PSGDRG       DOSE+3
>> PSGDT        A10+5,25+2,W25+5
   PSGF2        39+8*,8+2*,A10+3*,A25+2*,DONE+2!,FF+1
>> PSGFD        A10+6*,O25+1*,25+2*,25+5*,25+6,25+9*,25+10,A25,A25+1,A25+5*
                A25+10*,A25+19*
>> PSGFLG       A25+11
>> PSGFOK(10    O25+1*
>> PSGFOK(25    A25+1*,A25+5*
>> PSGFOK(39    39+7*,39+12*,39+14*
>> PSGFOK(8     8+4*,8+7*
>> PSGNEDFD     39+1,O25+1
>> PSGNEFD      A10+6*,O25+1*,25+2,25+5*,25+6,25+9*,25+10,A25+1,A25+5*,A25+10*
                A25+18*,A25+19,W25+2,W25+5,DOSE+3
>> PSGNEFDO     25+2
>> PSGNEFDOLD   25+6*,25+10*,A25+10
>> PSGNESD      10+2,A10+1,A10+2*,A10+6*,O25+1,25+5,25+9,A25+5,A25+9,A25+10
                A25+14,A25+18,DOSE+3
>> PSGNESDO     10+2*
>> PSGOE3       8+4,8+8,25+1
>> PSGOLDED     25+6*,25+10*,A25+10
>> PSGORD       8+1
>> PSGOROE1     39+3*,A10*,A25*,DONE+1
   PSGP         8+1,O25+1,DOSE+4~*,DOSE+5
>> PSGS0XT      39+2,39+5,39+9,39+11,39+12,TIMES+1
>> PSGS0Y       39+3,39+4,39+5*,39+7*,39+12*,39+14*,DOSE+3
>> PSGSCH       39+5,A25+4,TIMES+3,DOSE+3
>> PSGSD        10+2*,A10,A10+1,A10+2*,A10+6*
>> PSGSI        8+1*,8+3,8+4*,8+6*,8+7*
>> PSGST        39+9,TIMES+4,TIMES+5,DOSE+1,DOSE+3
>> PSJSYSP      8+6
>> PSJSYSW0     O25+1
   SDT          DONE+2!
   TMPX         A10+5~*
   U            FF+1,DOSE+3
   X            39+3*,39+4*,39+5,39+6,39+7,39+8,39+9,39+10*,39+11,39+12,39+13
                39+14,8+2,8+3*,8+4,8+5,A10*,A10+1,A10+2,A10+3*,A10+4,A10+5*
                25+5~,25+8~,25+9,A25*,A25+1,A25+2,A25+3*,A25+4,A25+13,A25+15
                A25+16,A25+18~,TIMES+1!,TIMES+4!,TIMES+9!,TIMES+10!
                TIMES+11,DOSE+2~
   X1           A10+5*,25+5~*,25+8~,25+9*,A25+8~,A25+9*,A25+14*,A25+18~*
   X2           A10+5*,25+5~*,25+8~,25+9*,A25+8~,A25+9*,A25+10,A25+14*,A25+18~*
   X3           25+5~*,A25+18~*
   Y            39+8,8+2,A10+4,A10+5,A10+6,A25+2,A25+5,A25+14,DONE+1!,FF+1*
   Z            W25+1~,W25+2,DOSE+3*,DOSE+5*

Global Variables  ( * Changed  ! Killed)
   ^PS(51.1            TIMES+3
   ^PS(53.45           8+6
   ^TMP("CLOZFLG"      25+4,25+7,A25+7,A25+13

Naked Globals
   NONE

Cache Objects
   NONE

Marked Items
   NONE

Label References
   8            39+1,39+2,39+5,39+12,8+2,8+3,8+4,8+5
   10           8+4
   39           39+6,39+7,39+8,39+9,39+11,39+13
   @(           39+8,8+2,A10+4,A25+2
   A10          A10+2,A10+4,A10+5
   A25          A25+2,A25+4,A25+5,A25+11,A25+13,W25+2
   DEL          39+7,8+4
   DONE         39+3,A10,A25
   DOSE         W25+2
   FF           39+8,8+2,A10+4,A25+2
   O25          A10+1,A10+2
   TIMES        39+11
   W25          A25+1

External References
   ^%DT                A10+5,A25+5
   ^%DTC               A25+14
   C^%DTC              A10+5,25+5,25+9,A25+18
   YN^DICN             DEL+1
   $$ENDL^PSGDL        A25+4
   EN1^PSGDL           A25+4
   ENPREV^PSGDL        A10+2
   $$ENDD^PSGMI        10+2,A10+2,A10+6,O25+1,25+5,25+9,A25+5,A25+19
   ^PSGNE3             10+1
   ENFD^PSGNE3         25+2
   1^PSGOE42           NEXT+1
   ENFF^PSGOEM         FF+1
   ENHLP^PSGOEM        39+6,39+10,8+3,8+5,A10+3,A10+5,A25+3
   $$ODD^PSGS0         39+2
   ENCHK^PSGS0         39+13
   $$EDITSI^PSJBCMA5   8+1
   $$ENOSD^PSJDCU      O25+1
   $$ENQ^PSJORP2       DOSE+5
   $$ENBCMA^PSJUTL     8+7
   EFDNEW^PSJUTL       W25+6

*****   END   *****

   Press return to continue:

PSGOE42  * *  65 Lines,  3231 Bytes, Checksum: B12591176
                                                  Jun 01, 2016@09:50:20 page 3
              206 bytes in comments
PSGOE42  ;BIR/CML3-REGULAR ORDER ENTRY (CONT.) ;09 JAN 97 / 9:25 AM
         ;;5.0;INPATIENT MEDICATIONS ;**327**;16 DEC 97
         ;
         ;
1        ; provider
         I '+$G(PSJSYSU) S PSTMPI=PSGPR,PSTMPN=PSGPRN G A1
         I $S(+PSJSYSU=3:0,1:$P(PSJSYSU,";",2)) G:$P(PSJSYSW0,"^",24) 5 G DONE
         S PSTMPI=PSGPR,PSTMPN=PSGPRN
         ;;A1 W !,"PROVIDER: ",$S(PSGPR:PSGPRN_"// ",1:"") R X:DTIME I X="^"!'$T
           W:'$T $C(7) S PSGOROE1=1 G DONE
A1       W !,"PROVIDER: ",$S(PSGPR:PSGPRN_"// ",1:"") R X:DTIME I X="^" W $C(7) 
          S PSGOROE1=1 G DONE
         I $S(X="":'PSGPR,1:X="@") W $C(7),"  (Required)" S X="?",PSGF2=1 D ENHL
          P^PSGOEM(53.1,1) G 1
         I X="",PSGPR S X=PSGPRN I PSGPR'=PSGPRN,$D(^VA(200,PSGPR,"PS")) W "    
          "_$P(^("PS"),"^",2)_"    "_$P(^("PS"),"^",3) S PSGFOK(1)="" G A2
         S PSGF2=1 I X?1."?" D ENHLP^PSGOEM(53.1,1)
         I $E(X)="^" D FF G:Y>0 @Y G 1
         K DIC S DIC="^VA(200,",DIC(0)="EMQZ",DIC("S")="I $D(^(""PS"")),^(""PS""
          ),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)>DT)" D ^DIC K DI
          C I Y'>0 G 1
         S PSGPR=+Y,PSGPRN=$P(Y(0,0),"^"),PSGFOK(1)=""
A2       ;; START NCC T4 MODS >> 327*RJS
         I '$G(PSGDRG) S PSGDRG=$O(^PSDRUG("ASP",PSGPDRG,0)) I PSGDRG,'$O(^(PSGD
          RG)) Q
         I $D(^PSDRUG("ACLOZ",PSGDRG)) D
         .S ANQX=0 D PROVCHK^PSJCLOZ(PSGPR) ;(PSGP,PSGDRG)
         .I ANQX=0 K PSTMPN,PSTMPI
         I $G(ANQX) S PSGPR=PSTMPI,PSGPRN=PSTMPN  W ! K ANQX G A1
         ;; END NCC T4 MODS << 327*RJS
5        ; self med
         I '$P(PSJSYSW0,"^",24) G DONE
A5       W !,"SELF MED: " W:PSGSM]"" $P("NO^YES","^",PSGSM+1),"// " R X:DTIME I 
          X="^"!'$T W:'$T $C(7) S PSGOROE1=1 G DONE
         I "01"[X,$L(X)<2 S:PSGSM=""&(X]"") PSGSM=X W:PSGSM]"" "  (",$P("NO^YES"
          ,"^",PSGSM+1),")" G DONE
         I X="@" W:PSGSM="" $C(7),"  ??" G:PSGSM="" A5 D DEL G:%'=1 A5 S (PSGSM,
          PSGHSM)="" G DONE
         S PSGF2=5 I X?1"^".E D FF G:Y>0 @Y G A5
         I X?1."?" S PSGF2=5 D ENHLP^PSGOEM(53.1,5) G A5
         D YN I  S PSGSM=$E(X)="Y",PSGFOK(5)="" G 6:PSGSM,DONE
         W $C(7) D ENHLP^PSGOEM(53.1,5) G A5
         ;
6        ; hospital supplied self med
         W !,"HOSPITAL SUPPLIED SELF MED: " W:PSGHSM]"" $P("NO^YES","^",PSGHSM+1
          ),"// " R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOROE1=1 G DONE
         I "01"[X,$L(X)<2 S:PSGHSM=""&(X]"") PSGHSM=X W:PSGHSM]"" "  (",$P("NO^Y
          ES","^",PSGHSM+1),")" G DONE
         I X="@" W:PSGHSM="" $C(7),"  ??" G:PSGHSM="" 6 D DEL G:%'=1 6 S PSGHSM=
          "" G DONE
         S PSGF2=6 I X?1"^".E D FF G:Y>0 @Y G 6
         I X?1."?" D ENHLP^PSGOEM(53.1,6) G 6
         D YN I  S PSGHSM=$E(X)="Y" G DONE
         W $C(7) S PSGF2=6 D ENHLP^PSGOEM(53.1,6) G 6
         Q
         ;
DONE     ;
         K F,F0,F1,PSGF2,F3,PSG,SDT Q
         ;
FF       ; up-arrow to another field
         D ENFF^PSGOEM I Y>0,Y'=1,Y'=5 S Y=Y_"^PSGOE4"_$S("^109^13^3^7^26^"[("^"
          _Y_"^"):"",1:1)
         Q
         ;
DEL      ; delete entry
         W !?3,"SURE YOU WANT TO DELETE" S %=0 D YN^DICN I %'=1 W $C(7),"  <NOTH
          ING DELETED>"
         Q
         ;
YN       ; yes/no as a set of codes
         I X'?.U F Y=1:1:$L(X) I $E(X,Y)?1L S X=$E(X,1,Y-1)_$C($A(X,Y)-32)_$E(X,
          Y+1,$L(X))
         F Y="NO","YES" I $P(Y,X)="" W $P(Y,X,2) Q
         Q
         ;
2        ; dispense drug multiple
         I PSGDRG,'$D(^PS(53.45,PSJSYSP,2)) S ^(2,0)="^53.4502P^1^1",^(1,0)=PSGD
          RG_"^"_PSGUD
         K DA,DR S DIE="^PS(53.45,",DA=PSJSYSP,DR=2,DR(2,53.4502)=$S($G(PSGFOK(1
          3)):.02,1:".01;.02") D ^DIE
         I '$O(^PS(53.45,PSJSYSP,2,0)) W $C(7),!!,"WARNING: This order must have
           at least one dispense drug before pharmacy can",!?9,"verify it!"
         I $G(PSGFOK(13)) Q
         G @FB

*****   INDEX OF PSGOE42   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
>> %            A5+2,6+3,DEL+1*
   ANQX         A2+3*,A2+4,A2+5!
   DA           2+2!*
   DIC          A1+5!*
   DIC("S"      A1+5*
   DIC(0        A1+5*
>> DIE          2+2*
   DR           2+2!*
   DR(2         2+2*
   DTIME        A1,A5,6+1
   F            DONE+1!
   F0           DONE+1!
   F1           DONE+1!
   F3           DONE+1!
>> FB           2+5
   PSG          DONE+1!
>> PSGDRG       A2+1*,A2+2,2+1
   PSGF2        A1+1*,A1+3*,A5+3*,A5+4*,6+4*,6+7*,DONE+1!
>> PSGFOK(1     A1+2*,A1+6*
>> PSGFOK(13    2+2,2+4
>> PSGFOK(5     A5+5*
>> PSGHSM       A5+2*,6+1,6+2*,6+3*,6+6*
>> PSGOROE1     A1*,A5*,6+1*
>> PSGPDRG      A2+1
>> PSGPR        1+1,1+3,A1,A1+1,A1+2,A1+6*,A2+3,A2+5*
>> PSGPRN       1+1,1+3,A1,A1+2,A1+6*,A2+5*
>> PSGSM        A5,A5+1*,A5+2*,A5+5*
>> PSGUD        2+1
>> PSJSYSP      2+1,2+2,2+3
>> PSJSYSU      1+1,1+2
>> PSJSYSW0     1+2,5+1
   PSTMPI       1+1*,1+3*,A2+4!,A2+5
   PSTMPN       1+1*,1+3*,A2+4!,A2+5
   SDT          DONE+1!
>> X            A1*,A1+1*,A1+2*,A1+3,A1+4,A5*,A5+1,A5+2,A5+3,A5+4,A5+5,6+1*,6+2
                6+3,6+4,6+5,6+6,YN+1*,YN+2
>> Y            A1+4,A1+5,A1+6,A5+3,6+4,FF+1*,YN+1*,YN+2*
>> Y(0          A1+6

Global Variables  ( * Changed  ! Killed)
   ^PS(53.45           2+1,2+3
   ^PSDRUG("ACLOZ"     A2+2
   ^PSDRUG("ASP"       A2+1
   ^VA(200             A1+2

Naked Globals
   ^(           A2+1
   ^("PS"       A1+2
   ^(1          2+1*
   ^(2          2+1*

Cache Objects
   NONE

Marked Items
   NONE

Label References
   1            A1+1,A1+4,A1+5
   5            1+2
   6            A5+5,6+3,6+4,6+5,6+7
   @(           A1+4,A5+3,6+4,2+5
   A1           1+1,A2+5
   A2           A1+2
   A5           A5+2,A5+3,A5+4,A5+6
   DEL          A5+2,6+3
   DONE         1+2,A1,5+1,A5,A5+1,A5+2,A5+5,6+1,6+2,6+3,6+6
   FF           A1+4,A5+3,6+4
   YN           A5+5,6+6

External References
   ^DIC                A1+5
   YN^DICN             DEL+1
   ^DIE                2+2
   ENFF^PSGOEM         FF+1
   ENHLP^PSGOEM        A1+1,A1+3,A5+4,A5+6,6+5,6+7
   PROVCHK^PSJCLOZ     A2+3

*****   END   *****

   Press return to continue:

PSGOE7   * *  114 Lines,  6233 Bytes, Checksum: B35767530
                                                  Jun 01, 2016@09:50:20 page 4
              958 bytes in comments
PSGOE7   ;BIR/CML3 - SELECT DRUG ;15 MAY 00 1:43 PM
         ;;5.0;INPATIENT MEDICATIONS;**9,26,34,52,55,50,87,111,181,254,267,260,2
          88,281,327**;16 DEC 97;Build 113
         ;
         ; Reference to ^PS(50.7 is supported by DBIA 2180
         ; Reference to ^PS(59.7 is supported by DBIA 2181
         ; Reference to ^PSDRUG( is supported by DBIA 2192
         ; Reference to ^TMP("PSODAOC",$J supported by DBIA 6071
         ;
         ; NFI-UD chgs for FR#: 1
         ; 
         ;S PSGDICS="U"_$S($D(PSJOERR):",I",1:"")
         S PSGDICS="U"
         ;
AD       ; Ask Drug
         K PSJDOSE,PSJDOX ;var array use in ^PSJDOSE
         K PSGODO,^TMP("PSJINTER",$J) D KILL^PSJBCMA5(+$G(PSJSYSP))
         K DIC S DIC="^PS(50.7,",DIC(0)="EMQZVT",D="B^C" I '$P(PSJSYSU,";",4) S 
          DIC("S")="I $$ENOISC^PSJUTL(Y,""U"")"
         E  D
         .I '$D(PSJDGCK) S DIC("T")="",DIC="^PSDRUG(",DIC("S")="I +$G(^PSDRUG(+Y
          ,2)),$P($G(^PSDRUG(+Y,2)),""^"",3)[""U"" S X(1)=+$G(^(""I"")) I $S('X(
          1):1,1:X(1)>DT)",D="B^C^VAPN^VAC^NDC^XATC"
         .I $D(PSJDGCK) S DIC("T")="",DIC="^PSDRUG(",DIC("S")="I +$G(^PSDRUG(+Y,
          2)),$$GCN^PSGOE7(+Y),$$PKGFLG^PSGOE7($P($G(^PSDRUG(+Y,2)),""^"",3)) S 
          X(1)=+$G(^(""I"")) I $S('X(1):1,1:X(1)>DT)",D="B^C^VAPN^VAC^NDC^XATC"
         ;
AD1      ;
         K PSGORD,PSJORD,PSJALLGY,PSGUSRX,^TMP("PSJINTER",$J),^PS(53.45,+$G(PSJS
          YSP),5),^PS(53.45,+$G(PSJSYSP),6)
         K ^TMP("PSODAOC",$J)
         S PSGORQF=0 R !!,"Select DRUG: ",X:DTIME I '$T W $C(7) S X="^"
         ; -- save off value of X in PSGUSRX so variable can be reliable checked
           at DO tag
         S PSGUSRX=X
         I $D(PSJDGCK) I ($G(PSJOCNT)'>1&(X="")) D  Q
         .W !!,"Not enough active profile drugs to perform drug check",!
         .K DIR S DIR(0)="E",DIR("A")="Press Return to Continue..." D ^DIR K DIR
           W @IOF
         I $D(PSJDGCK),X="" N PSGDGCKF S PSGDGCKF=1 G DGCKX
         I ("^"[X)!(X="") S PSGORQF=1 G DONE
         G:X?1"S."1.E DONE
         I X?1."?" W !!?2,"Select the medication you wish the patient to receive
          ." W:PSJSYSU<3 "  You should consult",!,"with your pharmacy before ord
          ering any non-formulary medication." W !
         D MIX^DIC1 G:X?1."?" AD1 G:"^"[X!(Y'>0) AD1 S (PSGDO,PSGDRG,PSGDRGN,PSG
          NEDFD,PSGPDRG,PSGPDRGN)=""
         I $D(PSJDGCK) I $$PSJSUPCK^PSJDGCK(+Y) G AD1
DGCKX    I $P(PSJSYSU,";",4) D  G DO
         .S:'$D(PSJDGCK) PSGDRG=+Y,PSGDRGN=Y(0,0)
         .S:$D(PSJDGCK)&'$D(PSGDGCKF) PSGDRG=+Y,PSGDRGN=Y(0,0)
         .S:$D(PSJDGCK)&$D(PSGDGCKF) PSGDRG=$P($$DGCKIEN^PSJDGCK(),";",2),PSGDRG
          N=$P($G(^PSDRUG(PSGDRG,0)),U)
         .D DIN^PSJDIN(+$G(^PSDRUG(PSGDRG,2)),PSGDRG)
         .I '$D(PSJDGCK) I $P(Y(0),"^",9) D NF S:Y>0 PSGDRG=+Y(0),PSGDRGN=Y(0,0)
           D SNFM
         .I $D(PSJDGCK)&'$D(PSGDGCKF) I $P(Y(0),"^",9) D NF S:Y>0 PSGDRG=+Y(0),P
          SGDRGN=Y(0,0) D SNFM
         .S PSGPDRG=+$G(^PSDRUG(PSGDRG,2)),PSGPDRGN=$$OINAME^PSJLMUTL(PSGPDRG)
         I '$D(PSJDGCK) S PSGPDRG=+Y,PSGPDRGN=$$OINAME^PSJLMUTL(PSGPDRG)
         I $D(PSJDGCK)&'$D(PSGDGCKF) S PSGPDRG=+Y,PSGPDRGN=$$OINAME^PSJLMUTL(PSG
          PDRG)
         ;F Q=1:1:$L(PSGDICS) S X=$P(PSGDICS,",",Q) Q:X=""  S PSJLUAPP=$O(^PS(50
          .3,PSGPDRG,1,"B",X,0)) I PSJLUAPP S X=$G(^PS(50.3,PSGPDRG,1,PSJLUAPP,0
          )) Q
         S X=$O(^PSDRUG("ASP",PSGPDRG,0)) I X,'$O(^(X)) S PSGDRG=X,PSGDRGN=$$END
          DN^PSGMI(X)
         ;
DO       ; dosage ordered
         N PSJALLGY,PSGFLG
         S PSGNEDFD=$$GTNEDFD("U",PSGPDRG)
         ; -- if PSGDGCKF is set, CK action is being used and no DRUG was entere
          d, do not set PSJALLGY array
         I $G(PSGDRG),$P(PSJSYSU,";",4) S:'$G(PSGDGCKF) PSJALLGY(PSGDRG)=$S($G(P
          SGUSRX)=""&($G(PSGDRG)):"",1:"P") D ENDDC^PSGSICHK(PSGP,PSGDRG) G:$G(P
          SGORQF) AD
         ;;START NCC T4 MODS >> 327*RJS
         I $P(PSJSYSU,";",4),$P($G(^PSDRUG(PSGDRG,"CLOZ1")),"^")="PSOCLO1" W !,"
          Now doing Clozapine Order checks.  Please wait...",! D
         . N RTN,ANQX
         . S ANQX=1,RTN=$P($G(^PSDRUG(PSGDRG,"CLOZ1")),U)
         . D:$L(RTN) ^@RTN
         . S:$G(ANQX) PSJORQF=1
         G:PSJORQF AD
         I '$P(PSJSYSU,";",4) S PSGX=PSGPDRG D  G:$G(ANQX) AD
         .S PSGDRG=0 F  S PSGDRG=$O(^PSDRUG("ASP",PSGPDRG,PSGDRG)) Q:'PSGDRG!($G
          (PSGFLG))  D
         ..I $G(^PSDRUG(PSGDRG,0))["CLOZAPINE" D
         ...N RTN
         ...S ANQX=1,RTN=$P($G(^PSDRUG(PSGDRG,"CLOZ1")),U)
         ...I $L(RTN) D ^@RTN S PSGFLG=1
         ...Q:$G(ANQX)
         S PSGDO=""
         ;; END NCC T4 MODS << 327*RJS
         ;
DONE     ;
         K DIC,%,%Y,PSGDICS,PSJLUAPP,Q1,Q2,Q3,Z,PSJALLGY,PSGUSRX Q
         ;
         ;
NF       ;
         S Y=0 W $C(7),!!,"PLEASE NOTE: The selected item is not currently on yo
          ur medical center's",!?13,"formulary." Q:'$P(PSJSYSU,";",2)
         N CNT S CNT=0 F Q1=0:0 S Q1=$O(^PSDRUG(PSGDRG,65,Q1)) Q:'Q1  I $$CHKDRG
          (+$G(^(Q1,0))) S CNT=CNT+1
         I CNT=0 W !!,"There are no formulary alternatives entered for this item
          ." W:PSJSYSU>2 "  You should consult",!,"with your pharmacy before ord
          ering this item." S Y=0 Q
         I CNT=1 S Q1=$O(^PSDRUG(PSGDRG,65,0)),Q1=+$G(^(Q1,0)),Q3=$P(^PSDRUG(Q1,
          0),"^") W !!,Q3," has been entered as a formulary " W:$X>67 ! W "alter
          native."
         I  F Q=1:1 S %=2 W !!,"Is ",$S(Q=1:"this",1:Q3)," acceptable" D YN^DICN
           Q:%  D NFOH
         I CNT=1 S:%=1 (Y(0),Y)=Q1,Y(0,0)=Q3 S:%<0 Y=-1 Q
         K DA,DIC S DA(1)=PSGDRG,DIC="^PSDRUG("_PSGDRG_",65,",DIC(0)="AEMQZ",DIC
          ("A")="Select FORMULARY ALTERNATIVE: " W ! D ^DIC K DIC Q
         ;
NFOH     ;
         S X="Answer 'YES' to order this formulary alternative ("_Q3_") for the 
          patient instead of the non-formulary item originally selected.  Answer
           'NO' to use the drug originally selected."
         W !!?2 F Y=1:1:$L(X," ") S Z=$P(X," ",Y) W:$L(Z)+$X+2>IOM ! W Z," "
         Q
CHKDRG(DRG) --
          ; Determine if dispense drug is valid for Unit Dose.
         I $D(^PSDRUG(DRG,0)),$P($G(^(2)),U,3)["U" S X=+$G(^("I")) I 'X!(X>DT) Q
           DRG
         Q 0
         ;
SNFM     ; show non-formulary message
         S Y=1 Q:PSJSYSU=3!'$O(^PS(59.7,1,21,0))  W $C(7),! S Q=0 F  S Q=$O(^PS(
          59.7,1,21,Q)) Q:'Q  W !,$G(^(Q,0))
         W ! D READ^PSJUTL S Y=1 Q
         ;
GTNEDFD(APP,PDRG) --
          ; Find defaults from Orderable Item.
         Q $P($G(^PS(50.7,+PDRG,0)),"^",5,8)
         N Q,X S X=""
         F Q=1:1:$L(APP) S X=$E(APP,Q) Q:X=""  S X=$O(^PS(50.3,+PDRG,1,"B",X,0))
           I X S X=$P($G(^PS(50.3,+PDRG,1,X,0)),"^",5,8) Q
         Q X
         ;
PKGFLG(PKF) --
          ;Return 0 for not in range of acceptable package flags, 1 for within r
a
          nge
         I $S(PKF["U":1,1:0) Q 1
         I $S(PKF["I":1,1:0) Q 1
         Q 0
         ;
GCN(PSGIENID) --
          ;Return 0 for not matched, 1 for matched with no GCNSEQNO, 1^1 for mat
c
          hed with a GCNSEQNO
         N PSGNDFID,PSGGCNPT,PSGGCNID
         S PSGNDFID=$P($G(^PSDRUG(PSGIENID,"ND")),"^"),PSGGCNPT=$P($G(^PSDRUG(PS
          GIENID,"ND")),"^",3)
         I 'PSGNDFID!('PSGGCNPT) Q 0
         S PSGGCNID=$$PROD0^PSNAPIS(PSGNDFID,PSGGCNPT)
         I $P(PSGGCNID,"^",7) Q PSGIENID_";"_PSGNDFID_";"_$P(PSGGCNID,"^",7)
         Q PSGIENID_";"_PSGNDFID

*****   INDEX OF PSGOE7   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
   %            DONE+1!,NF+5*,NF+6
   %Y           DONE+1!
   ANQX         DO+7~,DO+8*,DO+10,DO+12,DO+16*,DO+18
   APP          GTNEDFD~,GTNEDFD+3
   CNT          NF+2~*,NF+3,NF+4,NF+6
>> D            AD+3*,AD+5*,AD+6*
   DA           NF+7!
   DA(1         NF+7*
   DIC          AD+3!*,AD+5*,AD+6*,DONE+1!,NF+7!*
   DIC("A"      NF+7*
   DIC("S"      AD+3*,AD+5*,AD+6*
   DIC("T"      AD+5*,AD+6*
   DIC(0        AD+3*,NF+7*
   DIR          AD1+8!
   DIR("A"      AD1+8*
   DIR(0        AD1+8*
   DRG          CHKDRG~,CHKDRG+1
   DT           CHKDRG+1
   DTIME        AD1+3
   IOF          AD1+8
   IOM          NFOH+2
   PDRG         GTNEDFD~,GTNEDFD+1,GTNEDFD+3
   PKF          PKGFLG~,PKGFLG+1,PKGFLG+2
   PSGDGCKF     AD1+9~*,DGCKX+2,DGCKX+3,DGCKX+6,DGCKX+9,DO+4
   PSGDICS      PSGOE7+11*,DONE+1!
>> PSGDO        AD1+13*,DO+19*
>> PSGDRG       AD1+13*,DGCKX+1*,DGCKX+2*,DGCKX+3*,DGCKX+4,DGCKX+5*,DGCKX+6*
                DGCKX+7,DGCKX+11*,DO+4,DO+6,DO+8,DO+13*,DO+14,DO+16,NF+2,NF+4
                NF+7
>> PSGDRGN      AD1+13*,DGCKX+1*,DGCKX+2*,DGCKX+3*,DGCKX+5*,DGCKX+6*,DGCKX+11*
   PSGFLG       DO+1~,DO+13,DO+17*
   PSGGCNID     GCN+1~,GCN+4*,GCN+5
   PSGGCNPT     GCN+1~,GCN+2*,GCN+3,GCN+4
   PSGIENID     GCN~,GCN+2,GCN+5,GCN+6
   PSGNDFID     GCN+1~,GCN+2*,GCN+3,GCN+4,GCN+5,GCN+6
>> PSGNEDFD     AD1+13*,DO+2*
   PSGODO       AD+2!
   PSGORD       AD1+1!
>> PSGORQF      AD1+3*,AD1+10*,DO+4
>> PSGP         DO+4
>> PSGPDRG      AD1+13*,DGCKX+7*,DGCKX+8*,DGCKX+9*,DGCKX+11,DO+2,DO+12,DO+13
>> PSGPDRGN     AD1+13*,DGCKX+7*,DGCKX+8*,DGCKX+9*
   PSGUSRX      AD1+1!,AD1+5*,DO+4,DONE+1!
>> PSGX         DO+12*
   PSJALLGY     AD1+1!,DO+1~,DONE+1!
   PSJALLGY(    DO+4*
>> PSJDGCK      AD+5,AD+6,AD1+6,AD1+9,AD1+14,DGCKX+1,DGCKX+2,DGCKX+3,DGCKX+5
                DGCKX+6,DGCKX+8,DGCKX+9
   PSJDOSE      AD+1!
   PSJDOX       AD+1!
   PSJLUAPP     DONE+1!
>> PSJOCNT      AD1+6
   PSJORD       AD1+1!
>> PSJORQF      DO+10*,DO+11
>> PSJSYSP      AD+2,AD1+1
>> PSJSYSU      AD+3,AD1+12,DGCKX,DO+4,DO+6,DO+12,NF+1,NF+3,SNFM+1
   Q            NF+5*,SNFM+1*,GTNEDFD+2~,GTNEDFD+3*
   Q1           DONE+1!,NF+2*,NF+4*,NF+6
   Q2           DONE+1!
   Q3           DONE+1!,NF+4*,NF+5,NF+6,NFOH+1
   RTN          DO+7~,DO+8*,DO+9,DO+15~,DO+16*,DO+17
   U            DGCKX+3,DO+8,DO+16,CHKDRG+1
   X            AD1+3*,AD1+5,AD1+6,AD1+9,AD1+10,AD1+11,AD1+12,AD1+13,DGCKX+11*
                NFOH+1*,NFOH+2,CHKDRG+1*,GTNEDFD+2~*,GTNEDFD+3*,GTNEDFD+4
>> Y            AD1+13,AD1+14,DGCKX+1,DGCKX+2,DGCKX+5,DGCKX+6,DGCKX+8,DGCKX+9
                NF+1*,NF+3*,NF+6*,NFOH+2*,SNFM+1*,SNFM+2*
>> Y(0          DGCKX+1,DGCKX+2,DGCKX+5,DGCKX+6,NF+6*
   Z            DONE+1!,NFOH+2*

Global Variables  ( * Changed  ! Killed)
   ^PS(50.3            GTNEDFD+3
   ^PS(50.7            GTNEDFD+1
   ^PS(53.45           AD1+1!
   ^PS(59.7            SNFM+1
   ^PSDRUG(            DGCKX+3,DGCKX+4,DGCKX+7,DO+6,DO+8,DO+14,DO+16,NF+2,NF+4
                       CHKDRG+1,GCN+2
   ^PSDRUG("ASP"       DGCKX+11,DO+13
   ^TMP("PSJINTER"     AD+2!,AD1+1!
   ^TMP("PSODAOC"      AD1+2!

Naked Globals
   ^(           DGCKX+11,NF+2,NF+4,SNFM+1
   ^("I"        CHKDRG+1
   ^(2          CHKDRG+1

Cache Objects
   NONE

Marked Items
   NONE

Label References
   $$CHKDRG     NF+2
   $$GTNEDFD    DO+2
   AD           DO+4,DO+11,DO+12
   AD1          AD1+13,AD1+14
   DGCKX        AD1+9
   DO           DGCKX
   DONE         AD1+10,AD1+11
   NF           DGCKX+5,DGCKX+6
   NFOH         NF+5
   SNFM         DGCKX+5,DGCKX+6

External References
   ^@(                 DO+9,DO+17
   ^DIC                NF+7
   MIX^DIC1            AD1+13
   YN^DICN             NF+5
   ^DIR                AD1+8
   $$ENDDN^PSGMI       DGCKX+11
   ENDDC^PSGSICHK      DO+4
   KILL^PSJBCMA5       AD+2
   $$DGCKIEN^PSJDGCK   DGCKX+3
   $$PSJSUPCK^PSJDGCK  AD1+14
   DIN^PSJDIN          DGCKX+4
   $$OINAME^PSJLMUTL   DGCKX+7,DGCKX+8,DGCKX+9
   READ^PSJUTL         SNFM+2
   $$PROD0^PSNAPIS     GCN+4

*****   END   *****

   Press return to continue:

PSGOE8   * *  152 Lines,  7935 Bytes, Checksum: B53571835
                                                  Jun 01, 2016@09:50:20 page 5
              812 bytes in comments
PSGOE8   ;BIR/CML3-EDIT ORDERS IN 53.1 ; 7/6/11 9:44am
         ;;5.0;INPATIENT MEDICATIONS ;**47,50,65,72,110,111,188,192,113,223,269,
          287,327**;16 DEC 97;Build 1
         ;
         ; Reference to ^PS(50.7 is supported by DBIA# 2180
         ; Reference to ^PS(51.1 is supported by DBIA 2177
         ; Reference to ^PS(51.2 is supported by DBIA# 2178
         ; Reference to ^PSDRUG is supported by DBIA# 2192
         ;
101      ;Orderable Item
         S MSG=0,F2=101,PSGOOPD=PSGPD,PSGOOPDN=PSGPDN S:PSGOEEF(F2) BACK="101^PS
          GOE8"
         S %=1 I $P(PSJSYSU,";",3)>1 W !!,$C(7),"WARNING!  If you change the dru
          g of an order, the Dosage Ordered and Dispense",!,"Drug(s) are deleted
          ." F  W !,"Do you wish to continue" S %=2 D YN^DICN Q:%
         I %'=1 G DONE
         ;; START NCC T4 MODS >> 327*RJS
A101     ;
         I $$PNDREN($G(PSGORD)) D  Q
         . W !!?5,"Orderable Item may not be edited at this point." D PAUSE^VALM
          1
         W !,"ORDERABLE ITEM: ",$S(PSGPD:PSGPDN_"// ",1:"") R X:DTIME I X="^"!'$
          T W:'$T $C(7) S PSGOEE=0 G DONE
A201     I X="",PSGPD S X=PSGPDN I PSGPD'=PSGPDN,$D(^PS(50.7,PSGPD,0)) G:'$G(ANQ
          X) DONE
         S PSGPDOLD=PSGPD,PSGPDNOLD=PSGPDN,PSGPDRGOLD=PSGPDRG
         I $S(X="@":1,X]"":0,1:'PSGPD) W $C(7),"  (Required)" S X="?" D ENHLP^PS
          GOEM(53.1,101) G A101
         I X?1."?" D ENHLP^PSGOEM(53.1,101)
         I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A101
         ;BHW;PSJ*5.0*192;Modify ^DIC call to use MIX^DIC and only B/C cross-ref
          erences
         K DIC,D S DIC="^PS(50.7,",DIC(0)="EMQZ",DIC("S")="I $$ENOISC^PSJUTL(Y,"
          "U"")",D="B^C" D MIX^DIC1 K DIC,D I Y'>0 G A101
         F  S %=2 D DH,YN^DICN Q:%
         I %'=1 G A101
         S (PSGPDRG,PSGPD)=+Y,(PSGPDN,PSGPDRGN)=$$OINAME^PSJLMUTL(PSGPDRG)
         S PSGNEDFD=$$GTNEDFD^PSGOE7("U",PSGPDRG)
         S PSGPDNX=1,PSGDO="",(PSGPDRG,PSGPD)=+Y,(PSGPDN,PSGPDRGN)=$$OINAME^PSJL
          MUTL(PSGPDRG) K ^PS(53.45,PSJSYSP,2) S X=$O(^PSDRUG("ASP",PSGPD,0)) I 
          X,'$O(^(X)) D
         .S ^PS(53.45,PSJSYSP,2,0)="^53.4502P^1^1",^(1,0)=X,^PS(53.45,PSJSYSP,2,
          "B",X,1)=""
         S PSGDRGTMP=X
         D ENDRG^PSGOEF1(PSGPD,0)
         I $D(^PSDRUG("ACLOZ",PSGDRGTMP)) D
         .D CLOZ^PSJCLOZ(DFN,PSGDRGTMP)
         I $G(ANQX) W ! S X=$E(PSGPDNOLD,0,4),PSGPDN=PSGPDNOLD,PSGPD=PSGPDOLD,PS
          GPDRG=PSGPDRGOLD K ANQX,PSGDRGTMP,PSGPDOLD,PSGPDNOLD,PSGPDRGOLD G A201
         G DONE
         ;; END NCC T4 MODS >> 327*RJS
         ;
109      ; dosage ordered
         S MSG=0,F2=109 S:PSGOEEF(F2) BACK="109^PSGOE8"
A109     ;
         I $$PNDREN($G(PSGORD)) D  Q
         . W !!?5,"Dosage may not be edited at this point." D PAUSE^VALM1
         S PSGOEEF(F2)=PSGOEE
         D EDITDOSE^PSJDOSE S X=PSGDO G DONE
         W !,"DOSAGE ORDERED: ",$S(PSGDO]"":PSGDO_"// ",1:"") R X:DTIME I X="^"!
          '$T W:'$T $C(7) S PSGOEE=0 G DONE
         I X=""&(PSGDO]"") S X=PSGDO
         I $$CHECK(PSJSYSP)&(X="")&(PSGDO']"") W $C(7),"    (Required) " G A109
         I $$CHECK(PSJSYSP)&(X="@") W $C(7),"      (Required) " G A109
         I '$$CHECK(PSJSYSP)&(X="@") S PSGDO="" G DONE
         I X?1."?" D ENHLP^PSGOEM(53.1,109) G A109
         I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A109
         I $E(X,$L(X))=" " F  S X=$E(X,1,$L(X)-1) Q:$E(X,$L(X))'=" "
         I $S(X?.E1C.E:1,$L(X)>20:1,X="":0,X["^":1,X?1.P:1,1:X=+X) W $C(7),"  ",
          $S(X?1.P!(X=""):"(Required)",1:"??") D ENHLP^PSGOEM(53.1,109) G A109
         S PSGDO=X G DONE
         ;
3        ; med route
         S MSG=0,F2=3 S:PSGOEEF(F2) BACK="3^PSGOE8"
A3       I $$PNDREN($G(PSGORD)) D  Q
         . W !!?5,"Med Route may not be edited at this point." D PAUSE^VALM1
         W !,"MED ROUTE: ",$S(PSGMR:PSGMRN_"// ",1:"") R X:DTIME I X="^"!'$T W:'
          $T $C(7) S PSGOEE=0 G DONE
         I X="",PSGMR S X=PSGMRN I PSGMR'=PSGMRN,$D(^PS(51.2,PSGMR,0)) W "  "_$P
          (^(0),"^",3) G DONE
         I $S(X="@":1,X]"":0,1:'PSGMR) W $C(7),"  (Required)" S X="?" D ENHLP^PS
          GOEM(53.1,3) G A3
         I X?1."?" D ENHLP^PSGOEM(53.1,3)
         I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A3
         K DIC S DIC="^PS(51.2,",DIC(0)="EMQZ",DIC("S")="I $P(^(0),""^"",4)" D ^
          DIC K DIC I Y'>0 G A3
         S PSGMR=+Y,PSGMRN=Y(0,0) G DONE
         ;
26       ; schedule
         S MSG=0,F2=26 S:PSGOEEF(F2) BACK="26^PSGOE8"
A26      I $$PNDREN($G(PSGORD)) D  Q
         . W !!?5,"Schedule may not be edited at this point." D PAUSE^VALM1
         W !,"SCHEDULE: ",$S(PSGSCH]"":PSGSCH_"// ",1:"") R X:DTIME I X="^"!'$T 
          W:'$T $C(7) S PSGOEE=0 G DONE
         S:X="" X=PSGSCH,PSGSCH="" I "@"[X W $C(7),"  (Required)" S X="?" D ENHL
          P^PSGOEM(53.1,26) G A26
         S DOW=0 I $$DOW^PSIVUTL($$ENLU^PSGMI(X)) S DOW=1
         I X?1."?" D ENHLP^PSGOEM(53.1,26) G A26
         I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A26
         ;BHW;PSJ*5*188;Add flag and IEN return variable for PSGS0 (PSJ*5*134), 
          Highlight Admin Times if they changed.
         N PSGOES,PSJSLUP,PSGSFLG S PSJSLUP=1,PSGSFLG=1 D EN^PSGS0 I '$D(X) W $C
          (7),"  ??" S X="?" D ENHLP^PSGOEM(53.1,26) G A26
         I X'=PSGSCH D
         . N XX
         . S PSGSCH=X
         . I PSGS0Y'=PSGAT S PSGAT=PSGS0Y  ;Change so that any schedule change w
          ill adjust the type and default the admin times - DRF
         . D  ;Change schedule type to agree with schedule
         .. I $G(DOW) S PSGST="C",PSGSTN=$$ENSTN^PSGMI(PSGST) Q
         .. I (PSGSCH[" PRN")!(PSGSCH="PRN") I $$PRNOK^PSGS0(PSGSCH) S PSGOST=PS
          GST,PSGST="P",PSGSTN=$$ENSTN^PSGMI(PSGST) Q
         .. I PSGSCH]"" S XX=+$O(^PS(51.1,"AC","PSJ",PSGSCH,0))
         .. S PSGOST=$G(PSGST),PSGST=$P($G(^PS(51.1,XX,0)),"^",5) I PSGST="D" S 
          PSGST="C"  ;DOW schedules are converted to Continuous
         .. S PSGSTN=$$ENSTN^PSGMI(PSGST)
         . I $G(PSJSYSW0),($P(PSJSYSW0,U,5)'=2),'$G(PSGEFN(8)) W !!,"NOTE: This 
          may cause the Admin Times and the Start Time to be out of sync."
         . W !!,"NOTE: This change in schedule also changes the ADMIN TIMES and 
          SCHEDULE TYPE.",!
         . S MSG=1 S:'$G(PSGOEEF(39)) PSGOEEF(39)=1  ;*287 - Prevent infinite lo
          op editing admin times
         . I $G(PSJNEWOE) D PAUSE^VALM1
         I PSGST="O" S PSGOEEF(7)=1
         G DONE
         ;
7        ; schedule type
         S MSG=0,F2=7 S:PSGOEEF(F2) BACK="7^PSGOE8"
A7       W !,"SCHEDULE TYPE: "_$S(PSGSTN]"":PSGSTN_"// ",1:"") R X:DTIME S X=$TR
          (X,"coprocf","COPROCF") I X="^"!'$T S PSGOEE=0 W $C(7) G DONE
         I X="" S X=PSGST,PSGSTN=$$ENSTN^PSGMI(X) W:PSGSTN]"" "  ",PSGSTN G DONE
         S:X="F" X="R"
         I ",?,??,C,O,OC,P,R,"'[(","_X_",") W " ??" G A7
         I $$PRNOK^PSGS0($G(PSGSCH)),X="C" W "  ??" G A7
         I X="@"!(X?1."?") W:X="@" $C(7),"  (Required)" S:X="@" X="?" D ENHLP^PS
          GOEM(53.1,7) G A7
         I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A7
         ;*223 Don't allow O sched type on C orders
         I X="O",$$SCHTP(PSGSCH)'="O" W !,"  SCHEDULE ("_PSGSCH_") is not a ONE 
          TIME Schedule." G A7
         ;*269 Don't allow C sched type on O orders
         I X="C",$$SCHTP(PSGSCH)="O" W !,"  SCHEDULE ("_PSGSCH_") is not a CONTI
          NUOUS Schedule." G A7
         S PSGOST=PSGST
         S PSGST=X,PSGSTN=$$ENSTN^PSGMI(X) W:PSGSTN]"" "  ",PSGSTN
         I X="P",$G(PSGAT)]"" S PSGOAT=PSGAT S PSGAT="" D
         .W !!,"NOTE: This change in schedule type also changes the ADMIN TIMES.
          ",!
         .S MSG=1,PSGOEEF(39)=1
         .I $G(PSJNEWOE) D PAUSE^VALM1
         ;
DONE     ;
         I PSGOEE G:'PSGOEEF(F2) @BACK S PSGOEE=PSGOEEF(F2)
         K PSGDRGTMP,PSGPDOLD,PSGPDNOLD,PSGPDRGOLD
         K F,F0,F2 Q
         ;
DEL      ; delete entry
         W !?3,"SURE YOU WANT TO DELETE" S %=0 D YN^DICN I %'=1 W $C(7),"  <NOTH
          ING DELETED>"
         Q
         ;
DH       ;
         W !!?2,"When the drug of an order is changed, the Dosage Ordered and Di
          spense Drug(s)",!,"for the order are no longer valid, and therefore de
          leted from the order.",!,"If possible, a new corresponding dispense dr
          ug will be added to the order."
         W !!?2,"Answer 'YES' to continue with this change.  Answer 'NO' to sele
          ct another",!,"drug or to accept the drug as it was.  Enter an '^' the
           exit this edit." Q
         ;
CHECK(PSJSYSP) --
          ; Check to see if multiple dispense drugs
         ; Input  -     PSJSYSP
         ; Returns  0 = only one.
         ;          1 = more than one
         ; Checks Inactive Date and doesn't count if < or = today.
         N PSJRSB,PSJINACT,PSJRBCNT S PSJRBCNT=0
         F PSJRSB=0:0 S PSJRSB=$O(^PS(53.45,PSJSYSP,2,PSJRSB)) Q:'PSJRSB  D
         .S PSJINACT=$P(^PS(53.45,PSJSYSP,2,PSJRSB,0),"^",3)
         .I (PSJINACT="")!((PSJINACT>0)&(PSJINACT>DT)) D
         ..S PSJRBCNT=$S('$D(PSJRBCNT):1,1:PSJRBCNT+1)
         Q $S(PSJRBCNT>1:1,1:0)
         ;
PNDREN(PNDON) --
          ;
         I PNDON'["P" Q 0
         S RNWL="^PS(53.1,"_+PNDON_",0)" S RNWL=$G(@(RNWL)) S RNWL=$S($P(RNWL,"^
          ",24)="R":1,1:0)
         Q RNWL
         ;
SCHTP(SCH) --
          ; *223 Return SCHedule type
         N X I SCH="" Q ""
         S X=$O(^PS(51.1,"APPSJ",SCH,0))
         Q:'$G(X) ""
         Q $P(^PS(51.1,X,0),"^",5)
         ;

*****   INDEX OF PSGOE8   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
>> %            101+2*,101+3,A201+7*,A201+8,DEL+1*
   ANQX         A201,A201+17!
>> BACK         101+1*,109+1*,3+1*,26+1*,7+1*,DONE+1
   D            A201+6!*
>> DFN          A201+16
   DIC          A201+6!*,A3+7!*
   DIC("S"      A201+6*,A3+7*
   DIC(0        A201+6*,A3+7*
>> DOW          A26+4*,A26+14
   DT           CHECK+8
   DTIME        A101+3,A109+5,A3+2,A26+2,A7
   F            DONE+3!
   F0           DONE+3!
   F2           101+1*,109+1*,A109+3,3+1*,26+1*,7+1*,DONE+1,DONE+3!
>> MSG          101+1*,109+1*,3+1*,26+1*,A26+21*,7+1*,A7+15*
   PNDON        PNDREN~,PNDREN+1,PNDREN+2
>> PSGAT        A26+12*,A7+13*
>> PSGDO        A201+11*,A109+4,A109+5,A109+6,A109+7,A109+9*,A109+14*
   PSGDRGTMP    A201+13*,A201+15,A201+16,A201+17!,DONE+2!
>> PSGEFN(8     A26+19
>> PSGMR        A3+2,A3+3,A3+4,A3+8*
>> PSGMRN       A3+2,A3+3,A3+8*
>> PSGNEDFD     A201+10*
>> PSGOAT       A7+13*
>> PSGOEE       A101+3*,A109+3,A109+5*,A3+2*,A26+2*,A7*,DONE+1*
>> PSGOEEF(     101+1,109+1,A109+3*,3+1,26+1,7+1,DONE+1
>> PSGOEEF(39   A26+21*,A7+15*
>> PSGOEEF(7    A26+23*
   PSGOES       A26+8~
>> PSGOOPD      101+1*
>> PSGOOPDN     101+1*
>> PSGORD       A101+1,A109+1,A3,A26
>> PSGOST       A26+15*,A26+17*,A7+11*
>> PSGPD        101+1,A101+3,A201,A201+1,A201+2,A201+9*,A201+11*,A201+14
                A201+17*
>> PSGPDN       101+1,A101+3,A201,A201+1,A201+9*,A201+11*,A201+17*
   PSGPDNOLD    A201+1*,A201+17!,DONE+2!
>> PSGPDNX      A201+11*
   PSGPDOLD     A201+1*,A201+17!,DONE+2!
>> PSGPDRG      A201+1,A201+9*,A201+10,A201+11*,A201+17*
>> PSGPDRGN     A201+9*,A201+11*
   PSGPDRGOLD   A201+1*,A201+17!,DONE+2!
>> PSGS0Y       A26+12
>> PSGSCH       A26+2,A26+3*,A26+9,A26+11*,A26+15,A26+16,A7+4,A7+8,A7+10
   PSGSFLG      A26+8~*
>> PSGST        A26+14*,A26+15*,A26+17*,A26+18,A26+23,A7+1,A7+11,A7+12*
>> PSGSTN       A26+14*,A26+15*,A26+18*,A7,A7+1*,A7+12*
   PSJINACT     CHECK+5~,CHECK+7*,CHECK+8
>> PSJNEWOE     A26+22,A7+16
   PSJRBCNT     CHECK+5~*,CHECK+9*,CHECK+10
   PSJRSB       CHECK+5~,CHECK+6*,CHECK+7
   PSJSLUP      A26+8~*
   PSJSYSP      A201+11,A201+12,A109+7,A109+8,A109+9,CHECK~,CHECK+6,CHECK+7
>> PSJSYSU      101+2
>> PSJSYSW0     A26+19
>> RNWL         PNDREN+2*,PNDREN+3
   SCH          SCHTP~,SCHTP+1,SCHTP+2
   U            A26+19
   X            A101+3*,A201*,A201+2*,A201+3,A201+4,A201+11*,A201+12,A201+13
                A201+17*,A109+4*,A109+5*,A109+6*,A109+7,A109+8,A109+9,A109+10
                A109+11,A109+12*,A109+13,A109+14,A3+2*,A3+3*,A3+4*,A3+5,A3+6
                A26+2*,A26+3*,A26+4,A26+5,A26+6,A26+8*,A26+9,A26+11
                A7*,A7+1*,A7+2*,A7+3,A7+4,A7+5*,A7+6,A7+8,A7+10,A7+12,A7+13
                SCHTP+1~,SCHTP+2*,SCHTP+3,SCHTP+4
   XX           A26+10~,A26+16*,A26+17
>> Y            A201+4,A201+6,A201+9,A201+11,A109+11,A3+6,A3+7,A3+8,A26+6,A7+6
>> Y(0          A3+8

Global Variables  ( * Changed  ! Killed)
   ^PS(50.7            A201
   ^PS(51.1            A26+16,A26+17,SCHTP+2,SCHTP+4
   ^PS(51.2            A3+3
   ^PS(53.45           A201+11!,A201+12*,CHECK+6,CHECK+7
   ^PSDRUG("ACLOZ"     A201+15
   ^PSDRUG("ASP"       A201+11

Naked Globals
   ^(           A201+11
   ^(0          A3+3
   ^(1          A201+12*

Cache Objects
   NONE

Marked Items
   NONE

Label References
   $$CHECK      A109+7,A109+8,A109+9
   $$PNDREN     A101+1,A109+1,A3,A26
   $$SCHTP      A7+8,A7+10
   @(           A201+4,A109+11,A3+6,A26+6,A7+6,DONE+1
   A101         A201+2,A201+4,A201+6,A201+8
   A109         A109+7,A109+8,A109+10,A109+11,A109+13
   A201         A201+17
   A26          A26+3,A26+5,A26+6,A26+8
   A3           A3+4,A3+6,A3+7
   A7           A7+3,A7+4,A7+5,A7+6,A7+8,A7+10
   DH           A201+7
   DONE         101+3,A101+3,A201,A201+18,A109+4,A109+5,A109+9,A109+14,A3+2
                A3+3,A3+8,A26+2,A26+24,A7,A7+1

External References
   ^DIC                A3+7
   MIX^DIC1            A201+6
   YN^DICN             101+2,A201+7,DEL+1
   $$ENLU^PSGMI        A26+4
   $$ENSTN^PSGMI       A26+14,A26+15,A26+18,A7+1,A7+12
   $$GTNEDFD^PSGOE7    A201+10
   ENFF^PSGOE82        A201+4,A109+11,A3+6,A26+6,A7+6
   ENDRG^PSGOEF1       A201+14
   ENHLP^PSGOEM        A201+2,A201+3,A109+10,A109+13,A3+4,A3+5,A26+3,A26+5
                       A26+8,A7+5
   $$PRNOK^PSGS0       A26+15,A7+4
   EN^PSGS0            A26+8
   $$DOW^PSIVUTL       A26+4
   CLOZ^PSJCLOZ        A201+16
   EDITDOSE^PSJDOSE    A109+4
   $$OINAME^PSJLMUTL   A201+9,A201+11
   PAUSE^VALM1         A101+2,A109+2,A3+1,A26+1,A26+22,A7+16

*****   END   *****

   Press return to continue:

PSGOE81  * *  116 Lines,  6830 Bytes, Checksum: B40027816
                                                  Jun 01, 2016@09:50:20 page 6
              809 bytes in comments
PSGOE81  ;BIR/CML3-NON-VERIFIED ORDER EDIT (CONT.) ; 7/20/12 12:43am
         ;;5.0;INPATIENT MEDICATIONS;**26,50,64,58,82,110,111,136,113,267,327**;
          16 DEC 97;Build 158
         ;
39       ; admin times
         S MSG=0,PSGF2=39 S:PSGOEEF(PSGF2) BACK="39^PSGOE81",ORIG=$G(PSGAT)
A39      I $$ODD^PSGS0(PSGS0XT)!(PSGST="P")!$$PRNOK^PSGS0($G(PSGSCH)) G DONE
         W !,"ADMIN TIMES: "_$S(PSGAT:PSGAT_"// ",1:"") R X:DTIME I X="^"!('$T) 
          W:'$T $C(7) S PSGOEE=0 S:X="^" (X,PSGAT)=ORIG G DONE
         I X="" S:(($G(PSGS0XT)="D")&'PSGS0Y) PSGOEE=0 S:$G(PSGAT) X=PSGAT
         I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A39
         I X=" "!(X?1."?") D ENHLP^PSGOEM(53.1,39) G A39
         I PSGS0XT="D"&'$G(X) I ((",P,R,")'[(","_$G(PSGST)_",")) D  G A39
         .W $C(7),"  ??" S X="?" W !,"This is a 'DAY OF THE WEEK' schedule and M
          UST have admin times." D ENHLP^PSGOEM(53.1,39)
         I X="@" D DEL G:%'=1 A39 S PSGAT="",X=""
         I $G(PSGS0XT),'$$ODD^PSGS0(PSGS0XT),$G(PSGS0XT)'="P",$G(PSGS0XT)'="OC",
          '$$PRNOK^PSGS0(PSGSCH),($G(PSGST)'="O") D TIMES I '$D(X) G A39
         I (($G(PSGST)="O")!($G(PSGST)="OC")) I (X="") S (PSGAT,PSGS0Y)=X G DONE
         D ENCHK^PSGS0 I '$D(X) W $C(7) G A39
         S PSGOAT=PSGAT
         S (PSGS0Y,PSGAT)=X G DONE
         ;
8        ; special instructions
         S MSG=0,PSGF2=8 S:PSGOEEF(PSGF2) BACK="8^PSGOE81"
A8       ; special instructions
         ;I $E($G(X))=U D ENFF^PSGOE82 G:Y>0 @Y G A8
         S PSGSI=$$EDITSI^PSJBCMA5($G(PSGP),$G(PSGORD)) I $G(PSGP),$G(PSGORD) I 
          '$$DIFFSI^PSJBCMA5(PSGP,PSGORD) S PSGOEE=0 G DONE
         S PSGSI=$S((PSGSI>0&(PSGSI<4)):$G(^PS(53.45,+PSJSYSP,5,1,0))_" "_$G(^PS
          (53.45,+PSJSYSP,5,2,0)),PSGSI>3:"Instructions too long. See Order View
           or BCMA for full text",1:"")
         I PSGSI]"" S PSGSI=$$ENBCMA^PSJUTL("U") G DONE
         Q
         ;
10       ; start date/time
         S MSG=0,PSGF2=10 S:PSGOEEF(PSGF2) BACK="10^PSGOE81"
A10      ; start date/time
         K PSGSDX N DUR,DURMIN,TMPFD
         I $G(PSGORD)["P",$G(PSGP) I $$LASTREN^PSJLMPRI(PSGP,PSGORD) D  Q
         . W !?5,"Start Date may not be edited at this point. " D PAUSE^VALM1
         W !,"START DATE/TIME: "_$S($P(PSGSDN,"^")]"":$P(PSGSDN,"^")_"// ",1:"")
           R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOEE=0 G DONE
         I X="",PSGSD W "  "_$P(PSGSDN,"^") G DONE
         I X="P" D ENPREV^PSGDL W:'$D(X) $C(7) G:'$D(X) A10 S PSGSD=+X,PSGSDN=$$
          ENDD^PSGMI(PSGSD)_"^"_$$ENDTC^PSGMI(PSGSD) W "  ",$P(PSGSDN,"^") G DON
          E
         I X="@"!(X?1."?") W:X="@" $C(7),"  (Required)" S:X="@" X="?" D ENHLP^PS
          GOEM(53.1,10)
         I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A10
         NEW TMPX S TMPX=X,X1=+$G(PSGLI),X2=-7 D C^%DTC K %DT S %DT="ERTX",%DT(0
          )=X,X=TMPX D ^%DT K %DT I Y'>0 D ENHLP^PSGOEM(53.1,10) G A10
         I PSGFD<Y W $C(7),!?5,"*** THE START DATE CANNOT BE AFTER THE STOP DATE
          ! ***",! S MSG=1 G A10
         S (PSGSDX,PSGSD,PSGNESD)=+Y,PSGSDN=$$ENDD^PSGMI(PSGSD)_"^"_$$ENDTC^PSGM
          I(PSGSD)
         I $G(PSGORD)["P",$G(PSGP) S DUR=$$GETDUR^PSJLIVMD(PSGP,+PSGORD,"P",1) I
           DUR]"" S DURMIN=$$DURMIN^PSJLIVMD(DUR) I DURMIN D
         . S TMPFD=$$FMADD^XLFDT(PSGSD,,,DURMIN) K:(TMPFD<PSGSD) TMPFD I $G(TMPF
          D) S PSGFD=TMPFD,PSGFDN=$$ENDD^PSGMI(PSGFD)_"^"_$$ENDTC^PSGMI(PSGFD)
         G DONE
         ;
25       ; stop date
         S MSG=0,PSGF2=25 S:PSGOEEF(PSGF2) BACK="25^PSGOE81"
A25      ;
         K PSGFDX
         S PSGCFLG=0,PSGOLDED=PSGFD,PSGNEFDOLD=$G(PSGNEFD),PSGFDNOLD=PSGFDN
         W !,"STOP DATE/TIME: "_$S($P(PSGFDN,"^")]"":$P(PSGFDN,"^")_"// ",1:"") 
          R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOEE=0 G DONE
         I X="",PSGFD S X=$P(PSGFDN,"^") ;W "   "_$P(PSGFDN,"^")
         I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A25
         I X="@"!(X?1."?") W:X="@" $C(7),"  (Required)" S:X="@" X="?" D ENHLP^PS
          GOEM(53.1,25)
         I X=+X,(X>0),(X'>2000000) G A25:'$$ENDL^PSGDL(PSGSCH,X) K PSGDLS S PSGD
          L=X W " ...dose limit..." D ENE^PSGDL
         K %DT S %DT="ERTX",%DT(0)=PSGSD D ^%DT K %DT G:Y'>0 A25 S (PSGFDX,PSGFD
          ,PSGNEFD)=+Y,PSGFDN=$$ENDD^PSGMI(PSGFD)_"^"_$$ENDTC^PSGMI(PSGFD)
         ;/RJS Begin changes for emergency registration of clozapine patient Set
           end date to start date + 4 days at midnight.
         I $G(^TMP("CLOZFLG",DFN)) D  G:X>4 A25
         .S X1=+Y,X2=PSGSD D ^%DTC
         .Q:X'>4
         .I X>4 D
         ..W !!?13,"*** EMERGENCY SUPPLY NOT TO EXCEED 4 DAYS! ***",!
         ..S $P(PSGFD,".",2)=2359,X1=PSGSD,X2=4 D C^%DTC S PSGFD=X
         ..S $P(PSGFDN,"^",1)=$$ENDD^PSGMI(PSGFD),$P(PSGFDN,"^",2)=PSGFD
         ;/RJS End changes for emergency registration of clozapine patient Set e
          nd date to start date + 4 days at midnight.
         ;/RJS Begin verify that stop date does not exceed maximum days supply b
          ased on lab frequency
A255     I $D(CLOZPAT),'$G(^TMP("CLOZFLG",DFN)) D  Q
         .N X,X1,X2
         .S X1=PSGFD,X2=$S($G(CLOZPAT)=2:28,$G(CLOZPAT)=1:14,$G(CLOZPAT)=0:7,1:9
          0)
         .I $P(PSGFD,".",1)-$P(PSGSD,".",1)'=X2 S PSGCFLG=1,PSGFD=PSGOLDED,PSGNE
          FD=PSGNEFDOLD,PSGFDN=PSGFDNOLD W !!,"*** STOP DATE/TIME NOT TO EXCEED 
          "_X2_" DAYS! ***",! G A25
         .D C^%DTC S PSGFD=X,(PSGFDX,PSGFD,PSGNEFD)=+Y,PSGFDN=$$ENDD^PSGMI(PSGFD
          )_"^"_$$ENDTC^PSGMI(PSGFD)
         ;/RJS End verify that stop date does not exceed maximum days supply bas
          ed on lab frequency.
W25      ;
         N Z,MSG
         D DOSE I $G(Z)]"",Z>PSGNEFD D  G A25
         . S MSG(1)="There is no administration time that falls between the Star
          t Date/Time"
         . S MSG(2)="and the Stop Date/Time."
         . D EN^DDIOL(.MSG)
         I PSGFD<PSGDT W $C(7),!!?13,"*** WARNING! THE STOP DATE ENTERED IS IN T
          HE PAST! ***",! S MSG=1
         ;
DONE     ;
         ;Display Expected First Dose;BHW;PSJ*5*136
         D EFDNV^PSJUTL
         I PSGOEE G:'PSGOEEF(PSGF2) @BACK S PSGOEE=PSGOEEF(PSGF2)
         K ORIG,PSGCFLG,PSGOLDED,PSGNEFDOLD,PSGFDNOLD
         Q
         ;
FF       ; up-arrow to another field
         D ENFF^PSGOEM I Y>0,Y'=39,Y'=8,Y'=10,Y'=25 S Y=Y_"^PSGOE8"_$S("^109^13^
          3^7^26^"[("^"_Y_"^"):"",1:2) S:Y=2 FB=PSGF2_"^PSGOE81"
         Q
         ;
DEL      ; delete entry
         W !?3,"SURE YOU WANT TO DELETE" S %=0 D YN^DICN I %'=1 W $C(7),"  <NOTH
          ING DELETED>"
         Q
         ;
TIMES    ;At least one admin time, not more than interval allows.
         I ($G(PSGS0XT)'="O"),($G(PSGST)'="OC"),'$$PRNOK^PSGS0(PSGSCH) I X="" D 
          EN^DDIOL("This order requires at least one administration time.") K X 
          Q  ;No times
         N H,I,MAX
         I PSGSCH]"" I $D(^PS(51.1,"AC","PSJ",PSGSCH)) S H=+$O(^PS(51.1,"AC","PS
          J",PSGSCH,0)) S I=$P($G(^PS(51.1,H,0)),"^",3)
         I $G(PSGST)="O",$L(X,"-")>1 D EN^DDIOL("This is a One Time Order. Only 
          one administration time is permitted.") K X Q
         I $G(PSGST)="O" Q  ;Done validating One Time
         I +$G(I)=0 Q  ;No frequency - can not check frequency related items
         S MAX=1440/I
         I MAX<1,$L(X,"-")>1 D EN^DDIOL("This order requires one administration 
          time.") K X Q
         I MAX'<1,$L(X,"-")>MAX D EN^DDIOL("The number of admin times entered is
           greater than indicated by the schedule.") K X Q  ;Too many times
         I MAX'<1,$L(X,"-")<MAX D EN^DDIOL("The number of admin times entered is
           fewer than indicated by the schedule.")  ;Too few times
         Q
         ;
DOSE     ;Make certain at least one dose is given.
         N INFO,X
         S Z="",INFO=$S($G(PSGNESD):PSGNESD,1:$G(PSGSD))_U_($G(PSGNEFD))_U_($G(P
          SGSCH))_U_($G(PSGST))_U_($G(PSGDRG))_U_($G(PSGS0Y))
         Q:$G(PSGST)="OC"!($G(PSGST)="P")
         I '$L($G(PSGP)) N PSGP S PSGP=""
         S Z=$$ENQ^PSJORP2(PSGP,INFO)  ;Expected first dose.
         Q

*****   INDEX OF PSGOE81   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
>> %            A39+7,DEL+1*
   %DT          A10+9!*,A25+8!*
   %DT(0        A10+9*,A25+8*
>> BACK         39+1*,8+1*,10+1*,25+1*,DONE+3
>> CLOZPAT      A255,A255+2
>> DFN          A25+10,A255
   DTIME        A39+1,A10+4,A25+3
   DUR          A10+1~,A10+12*
   DURMIN       A10+1~,A10+12*,A10+13
>> FB           FF+1*
   H            TIMES+2~,TIMES+3*
   I            TIMES+2~,TIMES+3*,TIMES+6,TIMES+7
   INFO         DOSE+1~,DOSE+2*,DOSE+5
   MAX          TIMES+2~,TIMES+7*,TIMES+8,TIMES+9,TIMES+10
   MSG          39+1*,8+1*,10+1*,A10+10*,25+1*,W25+1~,W25+5,W25+6*
   MSG(1        W25+3*
   MSG(2        W25+4*
   ORIG         39+1*,A39+1,DONE+4!
>> PSGAT        39+1,A39+1*,A39+2,A39+7*,A39+9*,A39+11,A39+12*
   PSGCFLG      A25+2*,A255+3*,DONE+4!
>> PSGDL        A25+7*
   PSGDLS       A25+7!
>> PSGDRG       DOSE+2
>> PSGDT        W25+6
>> PSGF2        39+1*,8+1*,10+1*,25+1*,DONE+3,FF+1
>> PSGFD        A10+10,A10+13*,A25+2,A25+4,A25+8*,A25+15*,A25+16,A255+2,A255+3*
                A255+4*,W25+6
>> PSGFDN       A10+13*,A25+2,A25+3,A25+4,A25+8*,A25+16*,A255+3*,A255+4*
   PSGFDNOLD    A25+2*,A255+3,DONE+4!
   PSGFDX       A25+1!,A25+8*,A255+4*
>> PSGLI        A10+9
>> PSGNEFD      A25+2,A25+8*,A255+3*,A255+4*,W25+2,DOSE+2
   PSGNEFDOLD   A25+2*,A255+3,DONE+4!
>> PSGNESD      A10+11*,DOSE+2
>> PSGOAT       A39+11*
>> PSGOEE       A39+1*,A39+2*,A8+2*,A10+4*,A25+3*,DONE+3*
>> PSGOEEF(     39+1,8+1,10+1,25+1,DONE+3
   PSGOLDED     A25+2*,A255+3,DONE+4!
>> PSGORD       A8+2,A10+2,A10+12
   PSGP         A8+2,A10+2,A10+12,DOSE+4~*,DOSE+5
>> PSGS0XT      A39,A39+2,A39+5,A39+8,TIMES+1
>> PSGS0Y       A39+2,A39+9*,A39+12*,DOSE+2
>> PSGSCH       A39,A39+8,A25+7,TIMES+1,TIMES+3,DOSE+2
>> PSGSD        A10+5,A10+6*,A10+11*,A10+13,A25+8,A25+11,A25+15,A255+3,DOSE+2
>> PSGSDN       A10+4,A10+5,A10+6*,A10+11*
   PSGSDX       A10+1!,A10+11*
>> PSGSI        A8+2*,A8+3*,A8+4*
>> PSGST        A39,A39+5,A39+8,A39+9,TIMES+1,TIMES+4,TIMES+5,DOSE+2,DOSE+3
>> PSJSYSP      A8+3
   TMPFD        A10+1~,A10+13*!
   TMPX         A10+9~*
   U            DOSE+2
   X            A39+1*,A39+2*,A39+3,A39+4,A39+5,A39+6*,A39+7*,A39+8,A39+9
                A39+10,A39+12,A10+4*,A10+5,A10+6,A10+7*,A10+8,A10+9*,A25+3*
                A25+4*,A25+5,A25+6*,A25+7,A25+10,A25+12,A25+13,A25+15,A255+1~
                A255+4,TIMES+1!,TIMES+4!,TIMES+8!,TIMES+9!,TIMES+10
                DOSE+1~
   X1           A10+9*,A25+11*,A25+15*,A255+1~,A255+2*
   X2           A10+9*,A25+11*,A25+15*,A255+1~,A255+2*,A255+3
>> Y            A39+3,A10+8,A10+9,A10+10,A10+11,A25+5,A25+8,A25+11,A255+4,FF+1*
   Z            W25+1~,W25+2,DOSE+2*,DOSE+5*

Global Variables  ( * Changed  ! Killed)
   ^PS(51.1            TIMES+3
   ^PS(53.45           A8+3
   ^TMP("CLOZFLG"      A25+10,A255

Naked Globals
   NONE

Cache Objects
   NONE

Marked Items
   NONE

Label References
   @(           A39+3,A10+8,A25+5,DONE+3
   A10          A10+6,A10+8,A10+9,A10+10
   A25          A25+5,A25+7,A25+8,A25+10,A255+3,W25+2
   A39          A39+3,A39+4,A39+5,A39+7,A39+8,A39+10
   DEL          A39+7
   DONE         A39,A39+1,A39+9,A39+12,A8+2,A8+4,A10+4,A10+5,A10+6,A10+14,A25+3
   DOSE         W25+2
   TIMES        A39+8

External References
   ^%DT                A10+9,A25+8
   ^%DTC               A25+11
   C^%DTC              A10+9,A25+15,A255+4
   EN^DDIOL            W25+5,TIMES+1,TIMES+4,TIMES+8,TIMES+9,TIMES+10
   YN^DICN             DEL+1
   $$ENDL^PSGDL        A25+7
   ENE^PSGDL           A25+7
   ENPREV^PSGDL        A10+6
   $$ENDD^PSGMI        A10+6,A10+11,A10+13,A25+8,A25+16,A255+4
   $$ENDTC^PSGMI       A10+6,A10+11,A10+13,A25+8,A255+4
   ENFF^PSGOE82        A39+3,A10+8,A25+5
   ENFF^PSGOEM         FF+1
   ENHLP^PSGOEM        A39+4,A39+6,A10+7,A10+9,A25+6
   $$ODD^PSGS0         A39,A39+8
   $$PRNOK^PSGS0       A39,A39+8,TIMES+1
   ENCHK^PSGS0         A39+10
   $$DIFFSI^PSJBCMA5   A8+2
   $$EDITSI^PSJBCMA5   A8+2
   $$DURMIN^PSJLIVMD   A10+12
   $$GETDUR^PSJLIVMD   A10+12
   $$LASTREN^PSJLMPRI  A10+2
   $$ENQ^PSJORP2       DOSE+5
   $$ENBCMA^PSJUTL     A8+4
   EFDNV^PSJUTL        DONE+2
   PAUSE^VALM1         A10+3
   $$FMADD^XLFDT       A10+13

*****   END   *****

   Press return to continue:

PSGOE82  * *  118 Lines,  5496 Bytes, Checksum: B25952597
                                                  Jun 01, 2016@09:50:20 page 7
              852 bytes in comments
PSGOE82  ;BIR/CML3-NON-VERIFIED ORDER EDIT (CONT.) ;27 Jan 98 / 9:32 AM
         ;;5.0;INPATIENT MEDICATIONS ;**2,35,50,67,58,81,127,168,181,276,327**;1
          6 DEC 97;Build 3
         ;
         ; Reference to ^DD(53.1 is supported by DBIA #2256.
         ; Reference to ^VA(200 is supported by DBIA #10060.
         ; Reference to ^DIE is supported by DBIA #10018.
         ; Reference to ^DIC is supported by DBIA #10006.
         ; Reference to ^DICN is supported by DBIA #10009.
         ;
1        ; provider
         S MSG=0,PSGF2=1 S:PSGOEEF(PSGF2) BACK="1^PSGOE82"
A1       I $G(PSGORD)["P",$G(PSGP) I $$LASTREN^PSJLMPRI(PSGP,PSGORD) D  Q
         . W !?5,"This order has been renewed. Provider may not be edited at thi
          s point. " D PAUSE^VALM1
         S PSTMPI=PSGPR,PSTMPN=PSGPRN
         W !,"PROVIDER: ",$S(PSGPR:PSGPRN_"// ",1:"") R X:DTIME I X="^"!'$T W:'$
          T $C(7) S PSGOEE=0 G DONE
         I $S(X="":'PSGPR,1:X="@") W $C(7),"  (Required)" S X="?" D ENHLP^PSGOEM
          (53.1,1) G A1
         I X="",PSGPR S X=PSGPRN I PSGPR'=PSGPRN,$D(^VA(200,PSGPR,"PS")) W:0 "  
            "_$P(^("PS"),"^",2)_"    "_$P(^("PS"),"^",3) G:'$G(ANQX) DONE
         I +$G(ANQX) G A2
         I X?1."?" D ENHLP^PSGOEM(53.1,1)
         I $E(X)="^" D ENFF G:Y>0 @Y G A1
         K DIC S DIC="^VA(200,",DIC(0)="EMQZ",DIC("S")="I $D(^(""PS"")),^(""PS""
          ),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)>DT)" D ^DIC K DI
          C I Y'>0 G A1
         ;; START NCC T4 MODS >> 327*RJS
         S PSGPR=+Y,PSGPRN=Y(0,0)
A2       D CLOZPRV
         I $G(ANQX) S PSGPR=PSTMPI,PSGPRN=PSTMPN  K PSTMPN,PSTMPI G A1
         ;; END NCC T4 MODS << 327*RJS
         G DONE
         ;
5        ; self med
         S MSG=0,PSGF2=5 S:PSGOEEF(PSGF2) BACK="5^PSGOE82" K PSGOEEF(6) S:PSGSM 
          PSGOEEF(6)=1
A5       W !,"SELF MED: " W $P("NO^YES","^",PSGSM+1),"// " R X:DTIME I X="^"!'$T
           W:'$T $C(7) S PSGOEE=0 G DONE
         ;I "01"[X,$L(X)<2 S:PSGSM=""&(X]"") PSGSM=X W:PSGSM]"" "  (",$P("NO^YES
          ","^",PSGSM+1),")" G:'PSGSM DONE S PSGOEEF(6)=1 G 6
         I "01"[X,$L(X)<2 S:X]"" PSGSM=+X W:PSGSM]"" "  (",$P("NO^YES","^",PSGSM
          +1),")" G:'PSGSM DONE S PSGOEEF(6)=1 G 6
         I X="@" W $C(7),"  (Required)" G A5
         I X?1"^".E D ENFF G:Y>0 @Y G A5
         I X?1."?" D ENHLP^PSGOEM(53.1,5) G A5
         D YN I  S PSGSM=$E(X)="Y" K PSGOEEF(6) G:'PSGSM DONE S PSGOEEF(6)=1 G 6
         W $C(7) D ENHLP^PSGOEM(53.1,5) G A5
         ;
6        ; hospital supplied self med
         S MSG=0,PSGF2=6 S:PSGOEEF(PSGF2) BACK="6^PSGOE82"
A6       W !,"HOSPITAL SUPPLIED SELF MED: " W:PSGHSM]"" $P("NO^YES","^",PSGHSM+1
          ),"// " R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOEE=0 G DONE
         I "01"[X,$L(X)=1 S:X]"" PSGHSM=+X W "  (",$P("NO^YES","^",PSGHSM+1),")"
           S MSG=0,PSGF2=5 G DONE
         I X="@" W $C(7),"  (Required)" G A6
         I X?1"^".E D ENFF G:Y>0 @Y G A6
         I X?1."?" D ENHLP^PSGOEM(53.1,6) G A6
         D YN I  S PSGHSM=$E(X)="Y" S MSG=0,PSGF2=5 G DONE
         W $C(7) D ENHLP^PSGOEM(53.1,6) G A6
         ;
2        ; dispense drug multiple
         ;*276 - Disallow unauthorized nurses from editing Dispense Drug
         I '$P($G(PSJSYSU),";",4) W !,"You are not authorized to edit Dispense D
          rugs." D PAUSE^VALM1 Q
         S MSG=0,PSGF2=2,BACK="2^PSGOE82" K PSGOEEND
         N PSGX,PSGXX F PSGXX=0:0 S PSGX=PSGXX,PSGXX=$O(^PS(53.45,PSJSYSP,2,PSGX
          X)) Q:'PSGXX
         N PSJPNDRN I $G(PSGORD) I $E(PSGORD,$L(PSGORD))="P",$P($G(^PS(53.1,+PSG
          ORD,0)),"^",24)="R" S PSJPNDRN=1 D
         .S $P(PSJPNDRN,"^",2)="Dispense drugs for renewal orders cannot be dele
          ted, but can be given an INACTIVE DATE.  "
         N DA,DIC,DIE,DR,DIR S DIE="^PS(53.45,",DA=PSJSYSP,DR=2,DR(2,53.4502)=".
          01;.02"_$S($G(PSJPNDRN):";.03",1:"") D ^DIE
         I '$O(^PS(53.45,PSJSYSP,2,0)) W $C(7),!!,"WARNING: This order must have
           at least one dispense drug before pharmacy can",!?9,"verify it!",! S 
          MSG=1
         D DDOC(PSGX)
         NEW PSJDOSE
         D DOSECHK^PSJDOSE
         I +$G(PSJDSFLG) D DSPWARN^PSJDOSE S PSGOEEF(109)=1
         G DONE
         ;
40       ; comments
         S MSG=0,PSGF2=40,BACK="40^PSGOE82",DA=PSJSYSP,DR=1,DIE="^PS(53.45," D ^
          DIE W ! G DONE
         ;
66       ; provider comments
         ;S MSG=0,PSGF2=66,BACK="66^PSGOE82",DA=PSJSYSP,DR=4,DIE="^PS(53.45," D 
          ^DIE W ! G DONE
         ;
DONE     ;
         I PSGOEE G:'PSGOEEF(PSGF2) @BACK S PSGOEE=PSGOEEF(PSGF2)
         K F,F0,PSGF2,F3,PSG,SDT Q
         ;
ENFF     ; up-arrow to another field
         S Y=-1 I '$D(PSGOEEF)!(X?1"^"1.9N) W $C(7),"  ??" Q
         S X=$E(X,2,99) I X=+X S Y=$S($D(PSGOEEF(X)):X,1:-1) W "  " W:Y>0 $$CODE
          S2^PSIVUTL(53.1,X) W:Y'>0 $C(7),"??" Q
         K DIC S DIC="^DD(53.1,",DIC(0)="QEM",DIC("S")="I $D(PSGOEEF(+Y))" D ^DI
          C K DIC S Y=+Y S:Y>0 Y=$P($T(@("F"_Y)),";",3) Q
         ;
DEL      ; delete entry
         W !?3,"SURE YOU WANT TO DELETE" S %=0 D YN^DICN I %'=1 W $C(7),"  <NOTH
          ING DELETED>"
         Q
         ;
CLOZPRV  ;; START NCC T4 MODS >> 327*RJS
         I '$G(PSGDRG) S PSGDRG=$O(^PSDRUG("ASP",PSGPDRG,0)) I PSGDRG,'$O(^(PSGD
          RG)) Q
         I $D(^PSDRUG("ACLOZ",PSGDRG)) D
         .S ANQX=0 D PROVCHK^PSJCLOZ(PSGPR)
         .I ANQX=0 K PSTMPN,PSTMPI
         ;; END NCC T4 MODS << 327*RJS
         Q
         ;
YN       ; yes/no as a set of codes
         I X'?.U F Y=1:1:$L(X) I $E(X,Y)?1L S X=$E(X,1,Y-1)_$C($A(X,Y)-32)_$E(X,
          Y+1,$L(X))
         F Y="NO","YES" I $P(Y,X)="" W $P(Y,X,2) Q
         Q
DDOC(PSGX) --
          ; Order check on additional dispense drug for allergy and adv. reactio
n
          s.
         N PSGY,PSGND1,PSGND3,PSJALLGY
         S PSGY=0 F  S PSGX=$O(^PS(53.45,PSJSYSP,2,PSGX)) Q:'PSGX  S PSGY=$P($G(
          ^PS(53.45,PSJSYSP,2,PSGX,0)),"^") Q:PSGY=""  D
         . N INTERVEN,PSJDDI,PSJIREQ,PSJRXREQ,PSJDD,PSGORQF,PSJPDRG S PSJDD=PSGY
         . S Y=1,(PSJIREQ,PSJRXREQ,INTERVEN,X)=""
         . I '$G(PSJALGY1) S PSJALLGY(PSJDD)="" D ALLERGY^PSJOC
         . ;D IVSOL^PSGSICHK
         . I ($D(PSGORQF)) D
         .. K ^PS(53.45,PSJSYSP,2,PSGX),^PS(53.45,PSJSYSP,2,"B",PSGY)
         Q
         ;
F101     ;;101^PSGOE8
F109     ;;109^PSGOE8
F3       ;;3^PSGOE8
F7       ;;7^PSGOE8
PSGF26   ;;26^PSGOE8
F39      ;;39^PSGOE81
F8       ;;8^PSGOE81
F10      ;;10^PSGOE81
PSGF25   ;;25^PSGOE81
F1       ;;1^PSGOE82
F5       ;;5^PSGOE82
PSGF2    ;;2^PSGOE82

*****   INDEX OF PSGOE82   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
>> %            DEL+1*
>> ANQX         A1+5,A1+6,A2+1,CLOZPRV+3*,CLOZPRV+4
>> BACK         1+1*,5+1*,6+1*,2+3*,40+1*,DONE+1
   DA           2+7~*,40+1*
   DIC          A1+9!*,2+7~,ENFF+3!*
   DIC("S"      A1+9*,ENFF+3*
   DIC(0        A1+9*,ENFF+3*
   DIE          2+7~*,40+1*
   DIR          2+7~
   DR           2+7~*,40+1*
   DR(2         2+7*
   DTIME        A1+3,A5,A6
   F            DONE+2!
   F0           DONE+2!
   F3           DONE+2!
   INTERVEN     DDOC+3~,DDOC+4*
>> MSG          1+1*,5+1*,6+1*,A6+1*,A6+5*,2+3*,2+8*,40+1*
   PSG          DONE+2!
>> PSGDRG       CLOZPRV+1*,CLOZPRV+2
   PSGF2        1+1*,5+1*,6+1*,A6+1*,A6+5*,2+3*,40+1*,DONE+1,DONE+2!
>> PSGHSM       A6,A6+1*,A6+5*
   PSGND1       DDOC+1~
   PSGND3       DDOC+1~
>> PSGOEE       A1+3*,A5*,A6*,DONE+1*
>> PSGOEEF      ENFF+1
>> PSGOEEF(     1+1,5+1,6+1,DONE+1,ENFF+2
>> PSGOEEF(109  2+12*
>> PSGOEEF(6    5+1!*,A5+2*,A5+6!*
   PSGOEEND     2+3!
>> PSGORD       A1,2+5
   PSGORQF      DDOC+3~,DDOC+7
>> PSGP         A1
>> PSGPDRG      CLOZPRV+1
>> PSGPR        A1+2,A1+3,A1+4,A1+5,A1+11*,A2+1*,CLOZPRV+3
>> PSGPRN       A1+2,A1+3,A1+5,A1+11*,A2+1*
>> PSGSM        5+1,A5,A5+2*,A5+6*
   PSGX         2+4~*,2+9,DDOC~,DDOC+2*,DDOC+8
   PSGXX        2+4~*
   PSGY         DDOC+1~,DDOC+2*,DDOC+3,DDOC+8
>> PSJALGY1     DDOC+5
   PSJALLGY     DDOC+1~
   PSJALLGY(    DDOC+5*
   PSJDD        DDOC+3~*,DDOC+5
   PSJDDI       DDOC+3~
   PSJDOSE      2+10~
>> PSJDSFLG     2+12
   PSJIREQ      DDOC+3~,DDOC+4*
   PSJPDRG      DDOC+3~
   PSJPNDRN     2+5~*,2+6*,2+7
   PSJRXREQ     DDOC+3~,DDOC+4*
>> PSJSYSP      2+4,2+7,2+8,40+1,DDOC+2,DDOC+8
>> PSJSYSU      2+2
   PSTMPI       A1+2*,A2+1!,CLOZPRV+4!
   PSTMPN       A1+2*,A2+1!,CLOZPRV+4!
   SDT          DONE+2!
>> X            A1+3*,A1+4*,A1+5*,A1+7,A1+8,A5*,A5+2,A5+3,A5+4,A5+5,A5+6,A6*
                A6+1,A6+2,A6+3,A6+4,A6+5,ENFF+1,ENFF+2*,YN+1*,YN+2,DDOC+4*
>> Y            A1+8,A1+9,A1+11,A5+4,A6+3,ENFF+1*,ENFF+2*,ENFF+3*,YN+1*,YN+2*
                DDOC+4*
>> Y(0          A1+11

Global Variables  ( * Changed  ! Killed)
   ^PS(53.1            2+5
   ^PS(53.45           2+4,2+8,DDOC+2,DDOC+8!
   ^PSDRUG("ACLOZ"     CLOZPRV+2
   ^PSDRUG("ASP"       CLOZPRV+1
   ^VA(200             A1+5

Naked Globals
   ^(           CLOZPRV+1
   ^("PS"       A1+5

Cache Objects
   NONE

Marked Items
   $T(@(3)      ENFF+3

Label References
   6            A5+2,A5+6
   @(           A1+8,A5+4,A6+3,DONE+1
   A1           A1+4,A1+8,A1+9,A2+1
   A2           A1+6
   A5           A5+3,A5+4,A5+5,A5+7
   A6           A6+2,A6+3,A6+4,A6+6
   CLOZPRV      A2
   DDOC         2+9
   DONE         A1+3,A1+5,A2+3,A5,A5+2,A5+6,A6,A6+1,A6+5,2+13,40+1
   ENFF         A1+8,A5+4,A6+3
   YN           A5+6,A6+5

External References
   ^DIC                A1+9,ENFF+3
   YN^DICN             DEL+1
   ^DIE                2+7,40+1
   ENHLP^PSGOEM        A1+4,A1+7,A5+5,A5+7,A6+4,A6+6
   $$CODES2^PSIVUTL    ENFF+2
   PROVCHK^PSJCLOZ     CLOZPRV+3
   DOSECHK^PSJDOSE     2+11
   DSPWARN^PSJDOSE     2+12
   $$LASTREN^PSJLMPRI  A1
   ALLERGY^PSJOC       DDOC+5
   PAUSE^VALM1         A1+1,2+2

*****   END   *****

   Press return to continue:

PSGOE92  * *  118 Lines,  6308 Bytes, Checksum: B33386592
                                                  Jun 01, 2016@09:50:20 page 8
              827 bytes in comments
PSGOE92  ;BIR/CML3 - ACTIVE ORDER EDIT (CONT.) ; 2/18/10 4:15pm
         ;;5.0;INPATIENT MEDICATIONS ;**2,35,50,58,81,110,215,237,276,316,327**;
          16 DEC 97;Build 8
         ;
         ;Reference to ^DD(53.1 is supported by DBIA #2256.
         ;Reference to ^PS(55 is supported by DBIA #2191.
         ;Reference to ^PSDRUG is supported by DBIA #2192.
         ;
1        ; provider
         S MSG=0,PSGF2=1 S:PSGOEEF(PSGF2) BACK="1^PSGOE92"
A1       I $G(PSJORD),$G(PSGP) I $$COMPLEX^PSJOE(PSGP,PSJORD) S PSGOEE=0 D  G DO
          NE
         . W !!?5,"Provider may not be edited for active complex orders." D PAUS
          E^VALM1
         W !,"PROVIDER: ",$S(PSGPR:PSGPRN_"// ",1:"") R X:DTIME I X="^"!'$T W:'$
          T $C(7) S PSGOEE=0 G DONE
         S PSTMPI=PSGPR,PSTMPN=PSGPRN
         I $S(X="":'PSGPR,1:X="@") W $C(7),"  (Required)" S X="?" D ENHLP^PSGOEM
          (55.06,1) G A1
         I X="",PSGPR S X=PSGPRN I PSGPR'=PSGPRN,$D(^VA(200,PSGPR,"PS")) W:0 "  
            "_$P(^("PS"),"^",2)_"    "_$P(^("PS"),"^",3) G DONE
         ;; START NCC T4 MODS >> 327*RJS
         I +$G(ANQX) G A2
         I X?1."?" D ENHLP^PSGOEM(55.06,1)
         I $E(X)="^" D ENFF G:Y>0 @Y G A1
         K DIC S DIC="^VA(200,",DIC(0)="EMQZ",DIC("S")="I $D(^(""PS"")),^(""PS""
          ),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)>DT)" D ^DIC K DI
          C I Y'>0 G A1
         S PSGPR=+Y,PSGPRN=Y(0,0)
A2       D CLOZPRV^PSGOE82
         I $G(ANQX) W ! S PSGPR=PSTMPI,PSGPRN=PSTMPN  K PSTMPN,PSTMPI G A1
         ;; END NCC T4 MODS << 327*RJS
         G DONE
         ;
5        ; self med
         I $G(PSJORD),$G(PSGP) I $$COMPLEX^PSJOE(PSGP,PSJORD) S PSGOEE=0 D  G DO
          NE
         . W !!?5,"Self Med may not be edited for active complex orders." D PAUS
          E^VALM1
         S MSG=0,PSGF2=5 S:PSGOEEF(PSGF2) BACK="5^PSGOE92" K PSGOEEF(6) S:PSGSM 
          PSGOEEF(6)=""
A5       W !,"SELF MED: " W:PSGSM]"" $P("NO^YES","^",PSGSM+1),"// " R X:DTIME I 
          X="^"!'$T W:'$T $C(7) S PSGOEE=0 G DONE
         I "01"[X,$L(X)<2 S:X]"" PSGSM=+X W:PSGSM]"" "  (",$P("NO^YES","^",PSGSM
          +1),")" G:'PSGSM DONE S PSGOEEF(6)="" G 6
         I X="@" W $C(7),"  (Required)" G A5
         I X?1"^".E D ENFF G:Y>0 @Y G A5
         I X?1."?" D ENHLP^PSGOEM(55.06,5) G A5
         D YN I  S PSGSM=$E(X)="Y" K PSGOEEF(6) G:'PSGSM DONE S PSGOEEF(6)="" G 
          6
         W $C(7) D ENHLP^PSGOEM(55.06,5) G A5
         ;
6        ; hospital supplied self med
         S MSG=0,PSGF2=6 S:PSGOEEF(PSGF2) BACK="6^PSGOE92"
A6       I $G(PSJORD),$G(PSGP) I $$COMPLEX^PSJOE(PSGP,PSJORD) S PSGOEE=0 D  G DO
          NE
         . W !!?5,"Hospital Supplied Self Med may not be edited for active compl
          ex orders." D PAUSE^VALM1
         W !,"HOSPITAL SUPPLIED SELF MED: " W:PSGHSM]"" $P("NO^YES","^",PSGHSM+1
          ),"// " R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOEE=0 G DONE
         I "01"[X,$L(X)=1 S:X]"" PSGHSM=+X W "  (",$P("NO^YES","^",PSGHSM+1),")"
           S MSG=0,PSGF2=5 G DONE
         I X="@" W $C(7),"  (Required)" G A6
         I X?1"^".E D ENFF G:Y>0 @Y G A6
         I X?1."?" D ENHLP^PSGOEM(55.06,6) G A6
         D YN I  S PSGHSM=$E(X)="Y" S MSG=0,PSGF2=5 G DONE
         W $C(7) D ENHLP^PSGOEM(55.06,6) G A6
         ;
2        ; dispense drug multiple
         ;*276 - Disallow unauthorized nurses from editing Dispense Drug
         I '$P($G(PSJSYSU),";",4) W !,"You are not authorized to edit Dispense D
          rugs." D PAUSE^VALM1 Q
         I $G(PSGP),$G(PSGORD) I $$COMPLEX^PSJOE(PSGP,PSGORD) D
         . N X,Y,PARENT,P2ND S P2ND=$S(PSGORD["U":$G(^PS(55,PSGP,5,+PSGORD,.2)),
          1:$G(^PS(53.1,+PSGORD,.2))),PARENT=$P(P2ND,"^",8)
         . I PARENT D FULL^VALM1 W !!?5,"This order is part of a complex order. 
          Please review the following ",!?5,"associated orders before changing t
          his order." D CMPLX^PSJCOM1(PSGP,PARENT,PSGORD)
         S MSG=0,PSGF2=2,BACK="2^PSGOE92",PSGOEEND=1
         NEW PSGX,PSGXX F PSGXX=0:0 S PSGX=PSGXX,PSGXX=$O(^PS(53.45,PSJSYSP,2,PS
          GXX)) Q:'PSGXX
         K PSGXX
         N DA,DIE,DR S DIE="^PS(53.45,",DA=PSJSYSP,DR=2,DR(2,53.4502)=".02//1;.0
          3" D ^DIE
         I '$O(^PS(53.45,PSJSYSP,2,0)) W $C(7),!!,"WARNING: This order must have
           at least one dispense drug before pharmacy can",!?9,"verify it!",! S 
          MSG=1
         D DDOC^PSGOE82(PSGX) ;* Perform allergy/adv. reaction order checks
         NEW PSJDOSE
         D DOSECHK^PSJDOSE
         I +$G(PSJDSFLG) D DSPWARN^PSJDOSE S:$G(PSGOEEF(109))="" PSGOEEF(109)=1 
          ; PSJ*5*237 - Check PSGOEEF(109) to prevent infinite loop
         ; PSJ*5*215 - If Dispense Drug(s) changed, make entry in Activity Log.
         ; Compare the edited dispense drug information in ^PS(53.45 to the acti
          ve
         ; order dispense drug information in ^PS(55.
         S (PSJDDTMP,PSJDD55,PSJDTMP1,PSJDD551)=""
         F PSJDDTMP=0:0 S PSJDDTMP=$O(^PS(53.45,PSJSYSP,2,PSJDDTMP)) Q:'PSJDDTMP
            D
         . S PSJDDTMP(PSJDDTMP)=$G(^PS(53.45,PSJSYSP,2,PSJDDTMP,0))
         . S PSJDTMP1="Disp Drug: "_"("_$P($G(PSJDDTMP(PSJDDTMP)),"^",1)_") "_$P
          ($G(^PSDRUG($P($G(PSJDDTMP(PSJDDTMP)),"^",1),0)),"^")_" Units: "_$P($G
          (PSJDDTMP(PSJDDTMP)),"^",2)_" "
         F PSJDD55=0:0 S PSJDD55=$O(^PS(55,DFN,5,+ON,1,PSJDD55)) Q:'PSJDD55  D
         . S PSJDD55(PSJDD55)=$G(^PS(55,DFN,5,+ON,1,PSJDD55,0))
         . S PSJDD551="Disp Drug: "_"("_$P($G(PSJDD55(PSJDD55)),"^",1)_") "_$P($
          G(^PSDRUG($P($G(PSJDD55(PSJDD55)),"^",1),0)),"^")_" Units: "_$P($G(PSJ
          DD55(PSJDD55)),"^",2)_" "
         ; If the two temporary strings PSJDTMP1 and PSJDD551 do not match each 
          other exactly
         ; then an edit has been made to the Dispense Drug Field.  Make a new en
          try in
         ; the Activity Log for this order.
         I PSJDTMP1'=PSJDD551 D NEWUDAL^PSGAL5(DFN,+ON,6000,"Dispense Drug",PSJD
          D551)
         K PSGOEEND,PSJDDTMP,PSJDTMP1,PSJDD55,PSJDD551 G DONE
         ;
15       ; comments
         I $G(PSJORD),$G(PSGP) I $$COMPLEX^PSJOE(PSGP,PSJORD) S PSGOEE=0 D  G DO
          NE
         . W !!?5,"Comments may not be edited for active complex orders." D PAUS
          E^VALM1
         S MSG=0,PSGF2=15,BACK="15^PSGOE92",DA=PSJSYSP,DR=1,DIE="^PS(53.45," D ^
          DIE W ! G DONE
         ;
72       ; provider comments
         ;
DONE     ;
         I PSGOEE G:'PSGOEEF(PSGF2) @BACK S PSGOEE=PSGOEEF(PSGF2)
         K F,F0,PSGF2,F3,PSG,SDT Q
         ;
ENFF     ; up-arrow to another field
         S Y=-1 I '$D(PSGOEEF) W $C(7),"  ??" Q
         S X=$E(X,2,99) I X=+X S Y=$S($D(PSGOEEF(X)):X,1:-1) W "  " W:Y>0 $$CODE
          S2^PSIVUTL(53.1,X) W:Y'>0 $C(7),"??" Q
         K DIC S DIC="^DD(53.1,",DIC(0)="QEM",DIC("S")="I $D(PSGOEEF(+Y))" D ^DI
          C K DIC S Y=+Y S:Y>0 Y=$P($T(@("F"_Y)),";",3) Q
         ;
DEL      ; delete entry
         W !?3,"SURE YOU WANT TO DELETE" S %=0 D YN^DICN I %'=1 W $C(7),"  <NOTH
          ING DELETED>"
         Q
         ;
YN       ; yes/no as a set of codes
         I X'?.U F Y=1:1:$L(X) I $E(X,Y)?1L S X=$E(X,1,Y-1)_$C($A(X,Y)-32)_$E(X,
          Y+1,$L(X))
         F Y="NO","YES" I $P(Y,X)="" W $P(Y,X,2) Q
         Q
         ;
F101     ;;101^PSGOE9
F109     ;;109^PSGOE9
F3       ;;3^PSGOE9
F7       ;;7^PSGOE9
PSGF26   ;;26^PSGOE9
F41      ;;41^PSGOE91
F8       ;;8^PSGOE91
F10      ;;10^PSGOE91
F34      ;;34^PSGOE91
F1       ;;1^PSGOE92
F5       ;;5^PSGOE92
PSGF2    ;;2^PSGOE92

*****   INDEX OF PSGOE92   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
>> %            DEL+1*
>> ANQX         A1+7,A2+1
>> BACK         1+1*,5+3*,6+1*,2+6*,15+3*,DONE+1
   DA           2+9~*,15+3*
>> DFN          2+22,2+23,2+28
   DIC          A1+10!*,ENFF+3!*
   DIC("S"      A1+10*,ENFF+3*
   DIC(0        A1+10*,ENFF+3*
   DIE          2+9~*,15+3*
   DR           2+9~*,15+3*
   DR(2         2+9*
   DTIME        A1+2,A5,A6+2
   F            DONE+2!
   F0           DONE+2!
   F3           DONE+2!
>> MSG          1+1*,5+3*,6+1*,A6+3*,A6+7*,2+6*,2+10*,15+3*
>> ON           2+22,2+23,2+28
   P2ND         2+4~*
   PARENT       2+4~*,2+5
   PSG          DONE+2!
   PSGF2        1+1*,5+3*,6+1*,A6+3*,A6+7*,2+6*,15+3*,DONE+1,DONE+2!
>> PSGHSM       A6+2,A6+3*,A6+7*
>> PSGOEE       A1*,A1+2*,5+1*,A5*,A6*,A6+2*,15+1*,DONE+1*
>> PSGOEEF      ENFF+1
>> PSGOEEF(     1+1,5+3,6+1,DONE+1,ENFF+2
>> PSGOEEF(109  2+14*
>> PSGOEEF(6    5+3!*,A5+1*,A5+5!*
   PSGOEEND     2+6*,2+29!
>> PSGORD       2+3,2+4,2+5
>> PSGP         A1,5+1,A6,2+3,2+4,2+5,15+1
>> PSGPR        A1+2,A1+3,A1+4,A1+5,A1+11*,A2+1*
>> PSGPRN       A1+2,A1+3,A1+5,A1+11*,A2+1*
>> PSGSM        5+3,A5,A5+1*,A5+5*
   PSGX         2+7~*,2+11
   PSGXX        2+7~*,2+8!
   PSJDD55      2+18*,2+22*,2+23,2+24,2+29!
   PSJDD55(     2+23*,2+24
   PSJDD551     2+18*,2+24*,2+28,2+29!
   PSJDDTMP     2+18*,2+19*,2+20,2+21,2+29!
   PSJDDTMP(    2+20*,2+21
   PSJDOSE      2+12~
>> PSJDSFLG     2+14
   PSJDTMP1     2+18*,2+21*,2+28,2+29!
>> PSJORD       A1,5+1,A6,15+1
>> PSJSYSP      2+7,2+9,2+10,2+19,2+20,15+3
>> PSJSYSU      2+2
   PSTMPI       A1+3*,A2+1!
   PSTMPN       A1+3*,A2+1!
   SDT          DONE+2!
   X            A1+2*,A1+4*,A1+5*,A1+8,A1+9,A5*,A5+1,A5+2,A5+3,A5+4,A5+5,A6+2*
                A6+3,A6+4,A6+5,A6+6,A6+7,2+4~,ENFF+2*,YN+1*,YN+2
   Y            A1+9,A1+10,A1+11,A5+3,A6+5,2+4~,ENFF+1*,ENFF+2*,ENFF+3*,YN+1*
                YN+2*
   Y(0          A1+11

Global Variables  ( * Changed  ! Killed)
   ^PS(53.1            2+4
   ^PS(53.45           2+7,2+10,2+19,2+20
   ^PS(55              2+4,2+22,2+23
   ^PSDRUG(            2+21,2+24
   ^VA(200             A1+5

Naked Globals
   ^("PS"       A1+5

Cache Objects
   NONE

Marked Items
   $T(@(3)      ENFF+3

Label References
   6            A5+1,A5+5
   @(           A1+9,A5+3,A6+5,DONE+1
   A1           A1+4,A1+9,A1+10,A2+1
   A2           A1+7
   A5           A5+2,A5+3,A5+4,A5+6
   A6           A6+4,A6+5,A6+6,A6+8
   DONE         A1,A1+2,A1+5,A2+3,5+1,A5,A5+1,A5+5,A6,A6+2,A6+3,A6+7,2+29,15+1
                15+3
   ENFF         A1+9,A5+3,A6+5
   YN           A5+5,A6+7

External References
   ^DIC                A1+10,ENFF+3
   YN^DICN             DEL+1
   ^DIE                2+9,15+3
   NEWUDAL^PSGAL5      2+28
   CLOZPRV^PSGOE82     A2
   DDOC^PSGOE82        2+11
   ENHLP^PSGOEM        A1+4,A1+8,A5+4,A5+6,A6+6,A6+8
   $$CODES2^PSIVUTL    ENFF+2
   CMPLX^PSJCOM1       2+5
   DOSECHK^PSJDOSE     2+13
   DSPWARN^PSJDOSE     2+14
   $$COMPLEX^PSJOE     A1,5+1,A6,2+3,15+1
   FULL^VALM1          2+5
   PAUSE^VALM1         A1+1,5+2,A6+1,2+2,15+2

*****   END   *****

   Press return to continue:

PSGOER   * *  173 Lines,  11162 Bytes, Checksum: B88025707
                                                  Jun 01, 2016@09:50:20 page 9
              1212 bytes in comments
PSGOER   ;BIR/CML3 - RENEW A SINGLE ORDER ;4/27/11 9:54am
         ;;5.0;INPATIENT MEDICATIONS ;**11,30,29,35,70,58,95,110,111,133,141,198
          ,181,246,278,281,327**;16 DEC 97;Build 113
         ;
         ; Reference to ^PS(51.1 supported by DBIA 2177.
         ; Reference to ^PS(55 supported by DBIA 2191.
         ; Reference to ^PSSLOCK is supported by DBIA 2789.
         ; Reference to ^PSBAPIPM is supported by DBIA 3564.
         ; Reference to ^PS(59.7 is supported by DBIA 2181.
         ; Reference to ^PSDRUG( is supported by DBIA 2192.
         ; Reference to ^TMP("PSODAOC",$J is supported by DBIA 6071.
         ;
         ; renew a single order
         I $G(PSJCOM) D ^PSJCOMR Q
         N PSJEXPIR S PSJEXPIR=$$EXPIRED(PSGP,PSGORD) I PSJEXPIR D  Q
         .W !!?3,"  THIS ORDER" W:PSJEXPIR'=2 " HAS BEEN INACTIVE FOR ONE OR MOR
          E SCHEDULED",!?8," ADMINISTRATIONS AND"
         .W " CANNOT BE RENEWED!" D PAUSE^VALM1
         I $G(PSGSCH)]"",($G(PSGS0XT)="D"),($G(PSGAT)="") D  Q
         .N SWD,SDW,XABB,X,QX S X=$G(PSGSCH) D DW^PSGS0 Q:($G(X)="")  I $G(PSGS0
          XT)="" S PSGS0XT="D"
         .Q:((",P,R,")[(","_$G(PSGST)_","))
         .I $G(PSGS0XT)="D",$G(PSGAT)="" S CHK=1 W !!?3,"This order contains a '
          DAY OF THE WEEK' schedule without admin times"
         .W !?11," and CANNOT be renewed!" D PAUSE^VALM1
         I $G(PSGSCH)]"",'$$DOW^PSIVUTL(PSGSCH),'$$PRNOK^PSGS0(PSGSCH) I '$D(^PS
          (51.1,"AC","PSJ",PSGSCH)) D  Q
         .W !!?3,"This order contains an invalid schedule and CANNOT be renewed!
          " D PAUSE^VALM1
         W !! K DIR S DIR(0)="Y",DIR("A")=$S($P(PSJSYSP0,"^",3):"RENEW THIS ORDE
          R",1:"MARK THIS ORDER FOR RENEWAL"),DIR("B")="YES"
         S DIR("?")="Answer 'YES' to "_$S($P(PSJSYSP0,"^",3):"renew this order",
          1:"mark this order for renewal")_".  Answer 'NO' (or '^') to stop now.
          " D ^DIR
         I '$D(DIRUT),Y D NEW S PSGCANFL=1 D DONE Q
         I '$D(DIRUT),PSJSYSU S PSGND4=$G(^PS(55,PSGP,5,+PSGORD,4)) I $P(PSGND4,
          "^",15),$P(PSGND4,"^",16) D UNMARK,DONE Q
         D DONE,ABORT^PSGOEE
         Q
         ;
UNMARK   ;  
         W !!,"THIS ORDER HAS BEEN 'MARKED FOR RENEWAL'.",! K DIR S DIR(0)="Y",D
          IR("A")="DO YOU WANT TO 'UNMARK IT'",DIR("B")="NO"
         S DIR("?",1)="  Answer 'YES' to unmark this order.  Answer 'NO' (or '^'
          ) to leave the order",DIR("?")="marked.  (An answer is required.)" D ^
          DIR
         I 'Y D ABORT^PSGOEE G DONE
         S DA(1)=PSGP,DA=+PSGORD,PSGAL("C")=21180+PSJSYSU D ^PSGAL5 S $P(PSGND4,
          "^",15,17)="^^",^PS(55,PSGP,5,DA,4)=PSGND4 W "...DONE!"
         ;
DONE     ;
         K %DT,DA,DIE,DIR,DR,FDSD,PSGAL,PSGALR,PSGDL,PSGDLS,PSGFD,PSGFOK,PSGND4,
          PSGOEE,PSGOER0,PSGOER1,PSGOER2,PSGOERDP,PSGPOSA,PSGPOSD,PSGPR,PSGPX,PS
          GRD,PSGSD,PSGTOL,PSGTOO,PSGUOW,PSGWLL,RF Q
         ;
NEW      ; get info, write record
EXTEND   ; extend stop date on renewal order
         N DUOUT,PSJABT,PSGDRG,PSJREN,PSGOREAS S PSGDRG=$P($G(^PS(55,PSGP,5,+PSG
          ORD,1,1,0)),"^"),PSJREN=1
         I $G(PSGST)="O" N ACT S ACT=$$EN^PSBAPIPM(PSGP,PSGORD) I $P(ACT,"^",2),
          ($P(ACT,"^",3)="G") I $P(ACT,"^",2)>$P($G(^PS(55,PSGP,5,+PSGORD,2)),"^
          ",2) D  Q
         . W !!?5,"THIS ONE-TIME ORDER HAS ALREADY BEEN GIVEN AND CANNOT BE RENE
          WED",! S (DIRUT,PSGORQF)=1 D READ
         ;D OC55
         ;Q:$D(PSGORQF)  ; quit if not to continue
         ;; START NCC T4 MODS >> 327*RJS
         I $D(^PSDRUG("ACLOZ",PSGDRG)) N PSGPR S PSGPR=PSGOPR D CLOZ^PSJCLOZ(DFN
          ,PSGDRG) S:$G(ANQX) PSGCANFL=1
         ;; START NCC T4 MODS >> 327*RJS
         D NOW^%DTC S PSGDT=%,PSGND4=$G(^PS(55,PSGP,5,+PSGORD,4)) I '$P(PSJSYSP0
          ,"^",3) D MARK Q
         S PSGWLL=$S('$P(PSJSYSW0,"^",4):0,1:+$G(^PS(55,PSGP,5.1))),PSGOEE="R" K
           PSGOEOS
         K ^PS(53.45,PSJSYSP,1),^(2) D MOVE(3,1),MOVE(1,2)
         D DATE^PSGOER0(PSGP,PSGORD,PSGDT) I ($G(X)="^")!'$D(PSGFOK(106))!$G(DUO
          UT) D DONE,ABORT^PSGOEE S VALMBCK="R",COMQUIT=1 Q
         ;D OC55
         ;I $G(PSGORQF) D DONE,ABORT^PSGOEE S VALMBCK="R",COMQUIT=1 Q
SPEED    ;
         I +$G(PSJSYSU)=3 D EN^PSGPEN(PSGORD)
         Q:$G(DUOUT)
         N PSGOEAV S PSGOEAV=+PSJSYSU
         W !!,"...updating order..." K DA S DA(1)=PSGP,DA=+PSGORD,PSGAL("C")=PSJ
          SYSU*10+18000 D ^PSGAL5 W "."
         I $$LS^PSSLOCK(PSGP,PSGORD) D UPDREN(PSGORD,PSGDT,PSGOEPR,PSGOFD,PSJNOO
          ),UPDRENOE(PSGP,PSGORD,PSGDT) D UNL^PSSLOCK(PSGP,PSGORD)
         S ^TMP("PSODAOC",$J,"IP IEN")=PSGORD   ;set up which IEN will be used t
          o store order checks
         D SETOC^PSJNEWOC(PSGORD) ;PSJ*5*281 stores order checks
         K ^TMP("PSODAOC",$J),^TMP("PSJDAOC",$J)
         ;
         I 'PSGOERDP,$P(PSJSYSW0,"^",4),PSGFD'<PSGWLL S $P(^PS(55,PSGP,5.1),"^")
          =+PSGFD
         W ".DONE!" S VALMBCK="Q" Q
         ;
MARK     ;
         I $P(PSGND4,"^",15),$P(PSGND4,"^",16) W $C(7),!!?3,"...THIS ORDER IS AL
          READY MARKED FOR RENEWAL!..." Q
         K DA S $P(PSGND4,"^",15,17)="1^"_DUZ_"^"_PSGDT,^PS(55,PSGP,5,+PSGORD,4)
          =PSGND4,PSGAL("C")=13180,DA(1)=PSGP,DA=+PSGORD W "." D ^PSGAL5
         I $D(PSJSYSO) S PSGORD=+PSGORD_"A",PSGPOSA="R",PSGPOSD=PSGDT D ENPOS^PS
          GVDS
         Q
MOVE(X,Y) ; Move comments/dispense drugs from 55 to 53.45.
         S Q=0 F  S Q=$O(^PS(55,PSGP,5,+PSGORD,X,Q)) Q:'Q  S ^PS(53.45,PSJSYSP,Y
          ,Q,0)=$G(^(Q,0))
         S:Q ^PS(53.45,Y,0)="^53.450"_Y_"P^"_Q_U_Q
         Q
OC55     ;* Order checks for Speed finish and regular finish
         ;PSJ*5*181 - no longer use (OC will be triggered from OC^PSGOER0)
         Q
NEWOC55  ;
         N INTERVEN,PSJDDI,PSJIREQ,PSJRXREQ,PSJPDRG,PSJDD,PSJDD0,PSJALLGY
         S Y=1,(PSJIREQ,PSJRXREQ,INTERVEN,X)=""
         F PSGDDI=0:0 S PSGDDI=$O(^PS(55,PSGP,5,+PSGORD,1,PSGDDI)) Q:'+PSGDDI  D
         . S PSJDD0=$G(^PS(55,PSGP,5,+PSGORD,1,PSGDDI,0))
         . S PSJX=$P(PSJDD0,U,3) I PSJX]"",(PSJX'>$G(PSGDT)) Q
         . S PSJDD=+PSJDD0
         . S PSJX=$S('$D(^PSDRUG(+PSJDD,0)):1,$P($G(^(2)),U,3)'["U":1,$G(^("I"))
          ="":0,1:^("I")'>$G(PSGDT))
         . Q:PSJX
         . S PSJALLGY(PSJDD)=""
         S PSJDD=$O(PSJALLGY(0))
         I '+PSJDD W !!,"No active dispense drug was found" D PAUSE^PSJLMUT1 Q
         K PSGORQF D ENDDC^PSGSICHK(PSGP,PSJDD)
         D:'$G(PSGORQF) IN^PSJOCDS(PSGORD,"UD",PSJDD) Q:$G(PSGORQF)
         Q
UPDREN(PSGORD,RNWDT,PSGOEPR,PSGOFD,PSJNOO,RDUZ) --
          ; update renewed order
         N DR,DA,DIC,DIE,DD,DO,PSGRZERO,PSGRFOUR,PSGOORD
         S DR="",PSGOEENO=0,PSGOORD=PSGORD,PSGNESD=PSGSD Q:'PSGORD!'RNWDT!'PSGOE
          PR!'PSGOFD  S PSJNOO=$S($G(PSJNOO)]"":$G(PSJNOO),1:"E")
         S PSGRZERO="^PS(55,"_PSGP_",5,"_+PSGORD_",0)",PSGOEORD=$P(@PSGRZERO,"^"
          ,21)
         ; PSJ*5*141 - changed PSGOEPR to PSGPR for field 1 of the DR string bel
          ow.
         S DA(1)=PSGP,DA=+PSGORD,DIE="^PS(55,"_PSGP_",5," S DR="34////^S X=PSGFD
          " S:$G(PSGPR) DR=DR_";1////"_PSGPR_";110////"_PSJNOO D ^DIE
         K DR,DA,DIC,DIE,DD,DO S DIC="^PS(55,"_PSGP_",5,"_+PSGORD_",14,",DIC(0)=
          "L",DIC("P")="55.6114DA",ND14=$G(@(DIC_"0)")),DINUM=$P(ND14,"^",3)+1,D
          A(2)=PSGP,DA(1)=+PSGORD D
         . S DIC("DR")=".01////"_$G(RNWDT)_";1////"_$S($G(RDUZ):RDUZ,1:$G(DUZ))_
          ";2////"_$G(PSGOEPR)_";3////"_$G(PSGOFD)_";4////"_+PSGOEORD,X=$G(RNWDT
          ) D FILE^DICN
         K DR,DA,DIC,DIE,DD,DO S DA(1)=PSGP,DA=+PSGORD,DIE="^PS(55,"_PSGP_",5,",
          DR="28////A;105////@;107////@"
         ;PSJ*5*198
         S PSGRFOUR="^PS(55,"_PSGP_",5,"_+PSGORD_",4)",PSGRFOUR=@PSGRFOUR I $P(P
          SGRFOUR,"^",2)<RNWDT S DR=DR_";16////@;17////@" I $G(PSJORD)["P",+PSJS
          YSU=1 S DR=DR_";18////@;19////@"
         I '$G(PSJSPEED) I $G(PSGAT)]"",$G(PSGAT)'=$P($G(@(DIE_+PSGORD_",2)")),"
          ^",5) S DR=DR_";41////"_PSGAT
         D ^DIE
         ; PSJ*5*278 - Check to re-assign orderable item
         N PSGPOI S PSGPOI=$$ACTIVE^PSJORREN(PSGP,PSGORD) Q:+PSGPOI=1  ;Quit if 
          no change to OI
         I +PSGPOI>1,$P(PSGPOI,U,2) D  ;replace OI
         . N DR,DA,DIE S DA(1)=PSGP,DA=+PSGORD,DIE="^PS(55,"_PSGP_",5,",DR="108/
          //^S X=$P(PSGPOI,U,2)" D ^DIE
         Q
UPDRENOE(PSGP,PSGORD,RDATE) --
          ;
         D EXPOE(PSGP,PSGORD,$G(RDATE)) ; expire original Orders File order
         I PSGORD'["P" K DA,DR,DIE S DA(1)=DFN,DA=+PSGORD,DIE="^PS(55,"_DFN_$S(P
          SGORD="U":",5,",1:",""IV"","),DR=$S(DIE["IV":110,1:66)_"////@" D ^DIE
         D ENUDTX^PSJOREN(PSGP,PSGORD,"NR")
         D EN1^PSJHL2(PSGP,"SN",PSGORD,"ORDER RENEWED")
         Q
READ     ; hold screen
         I $D(IOST) Q:$E(IOST)'="C"
         W !?5,"Press return to continue  " R X:$S($D(DTIME):DTIME,1:300)
         Q
EXPOE(DFN,PSJORDER,EXPDT) --
          ; expire old Orders File entry
         I PSJORDER["P" S FILE="^PS(53.1,"_+PSJORDER_",0)",PSJORDER=$P(@FILE,"^"
          ,25)
         I (PSJORDER'["U"),(PSJORDER'["V") Q
         N CURDAT D NOW^%DTC S CURDAT=$$DATE2^PSJUTL2(%)
         S PSJEXPOE=$S($G(EXPDT):EXPDT,1:CURDAT) D EN1^PSJHL2(DFN,"SC",PSJORDER)
           K PSJEXPOE
         Q
EXPIRED(PSJX,PSJY) --
          ;
         ; INPUT 
         ;       PSJX - Pharmacy Patient, pointer to ^PS(55
         ;       PSJY - Inpatient Order Number(appended with "V" or "U")
         ; OUTPUT
         ;   0  -  Order has not exceeded the Expired Time Limit 
         ;   1  -  Order has exceeded the Expired Time Limit
         N STOP,STATUS,NOW,CUTOFF,FREQ,LAST,ST,X,DFN,U,PSGDT,SD,WD,PSJPSTO,PSGDW
          ,PSGOC,ZZND,LASTAT,LSTSTR,PSBCNT S DFN=PSJX,U="^",CUTOFF=0
         S STATUS=$S(PSJY["U":$P($G(^PS(55,PSJX,5,+PSJY,0)),"^",9),PSJY["V":$P($
          G(^PS(55,PSJX,"IV",+PSJY,0)),"^",17),1:"")
         S NOW=$S($G(PSGDT):PSGDT,1:$$DATE^PSJUTL2())
         S STOP=$S(PSJY["U":$P($G(^PS(55,PSJX,5,+PSJY,2)),U,4),1:$P($G(^PS(55,PS
          JX,"IV",+PSJY,0)),"^",3))
         I NOW<STOP Q 0
         I PSJY["U" N ND2,ND0 S ND0=$G(^PS(55,PSJX,5,+PSJY,0)),ND2=$G(^PS(55,PSJ
          X,5,+PSJY,2)),FREQ=$P(ND2,"^",6) D
         .N SCHED S SCHED=$P($G(^PS(55,PSJX,5,+PSJY,2)),"^") I SCHED["PRN" S FRE
          Q=$$PRNFREQ(SCHED)
         .S LSTSTR=$P(ND2,"^",2)_"^"_$P(ND2,"^",4)_"^"_SCHED_"^"_$P(ND0,"^",7)_"
          ^^"_$P(ND2,"^",5)
         .S LAST=$$EN^PSBAPIPM(PSJX,PSJY) I LAST,($P(ND0,"^",7)="O"),($P(LAST,"^
          ",3)="G") I LAST>$P(ND2,"^",2) S CUTOFF=$$FMADD^XLFDT(NOW,,-1) Q
         .I 'LAST!(LAST>$P(ND2,"^",4)) S LAST=$$LASTAT^PSJORP2(DFN,LSTSTR) S:LAS
          T CUTOFF=$$FMADD^XLFDT(LAST,,,FREQ) Q
         .I SCHED["PRN",($P(LSTSTR,"^",6)="") S CUTOFF=$$FMADD^XLFDT(LAST,,,FREQ
          ) Q
         .I $$DOW^PSIVUTL(SCHED) S CUTOFF=$$NXTDOW(DFN,$P(LSTSTR,"^"),$P(LSTSTR,
          "^",2),$P(LSTSTR,"^",3),$P(LSTSTR,"^",6)) Q
         .S LAST=$$EN^PSBAPIPM(PSJX,PSJY) I 'LAST!(LAST>$P(ND2,"^",4)) S CUTOFF=
          $$FMADD^XLFDT(NOW,,-1) Q
         .S $P(LSTSTR,"^")=$$FMADD^XLFDT(LAST,,,,1),$P(LSTSTR,"^",2)=$$FMADD^XLF
          DT(PSGDT,,,FREQ) S CUTOFF=$$ENQ^PSJORP2(PSJX,LSTSTR)
         I PSJY["V" N LIMIT S LIMIT=$P($G(^PS(59.7,1,31)),"^",4) S LIMIT=$S((LIM
          IT]""):+LIMIT,1:24) S CUTOFF=$$FMADD^XLFDT(STOP,,LIMIT) D
         .I '($G(P(4))]"") N P,YP,XP S YP=$G(^PS(55,DFN,"IV",+PSJY,0)) F XP=1:1:
          23 S P(XP)=$P(YP,U,XP)
         .Q:'($G(P(4))]"")
         .Q:'$$SCHREQ^PSJLIVFD(.P)
         .N INTERVAL,LSTSTR,ND0,SCHED,IVSTYP S ND0=$G(^PS(55,PSJX,"IV",+PSJY,0))
          ,INTERVAL=$P(ND0,"^",15),SCHED=$P(ND0,"^",9) Q:SCHED=""
         .S IVSTYP=$S($$DOW^PSIVUTL(SCHED):"D",INTERVAL="O":"O",1:"C"),LSTSTR=$P
          (ND0,"^",2)_"^"_$P(ND0,"^",3)_"^"_SCHED_"^"_IVSTYP_"^^"_$P(ND0,"^",11)
         .S LAST=$$EN^PSBAPIPM(PSJX,PSJY) I LAST,IVSTYP="O",LAST>$P(ND0,"^",2),(
          $P(LAST,"^",3)="G") S CUTOFF=$$FMADD^XLFDT(NOW,,-1) Q
         .I 'LAST!(LAST>$P(ND0,"^",3))!(LAST&(IVSTYP="O")) S CUTOFF=$$FMADD^XLFD
          T(NOW,,-1) Q
         .I IVSTYP="D" S CUTOFF=$$NXTDOW(LAST,SCHED,$G(P(2)),$P($G(P(9)),"@"),$G
          (P(11))) Q
         .I SCHED["PRN" S FREQ=$$PRNFREQ(SCHED) S CUTOFF=$$FMADD^XLFDT(LAST,,,FR
          EQ) Q
         .S LAST=$$EN^PSBAPIPM(PSJX,PSJY) I 'LAST!(LAST>$P(ND0,"^",3)) S CUTOFF=
          $$FMADD^XLFDT(NOW,,-1) Q
         .S $P(LSTSTR,"^")=$$FMADD^XLFDT(LAST,,,,1),$P(LSTSTR,"^",2)=$$FMADD^XLF
          DT(PSGDT,31) S CUTOFF=$$ENQ^PSJORP2(PSJX,LSTSTR)
         K LYN,PSBDT,PSBFLAG,PSBSTR
         Q $S(CUTOFF<NOW:1,1:0)
         ;
NXTDOW(DOWDFN,DOWSD,DOWFD,DOWSCH,DOWAT) --
          ;
         N NXTADM,DOWSTR S DOWSTR=$$FMADD^XLFDT(DOWFD,,,,1)_"^"_$$FMADD^XLFDT(DO
          WFD,7)_"^"_DOWSCH_"^D^^"_DOWAT S NXTADM=$$ENQ^PSJORP2(DOWDFN,DOWSTR)
         Q $S(NXTADM:NXTADM,1:DOWSD)
         ;
PRNFREQ(SCHED) --
          ;
         N ZZND,D,DA,X,PSGAT,PSGOES,PSGST,PSJNSS,PSJPWD,TEST,VALMBCK,PSGS0XT,PSG
          S0Y,PSGDT
         F X=$P(SCHED,"PRN"),$P(SCHED,"PRN",2),$P(SCHED," PRN"),$P(SCHED,"PRN ",
          2) Q:$P($G(ZZND),"^",4)  D ADMIN^PSJORPOE
         Q $S($G(PSGS0XT):PSGS0XT,1:1440)

*****   INDEX OF PSGOER   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
>> %            EXTEND+9,EXPOE+3
   %DT          DONE+1!
   ACT          EXTEND+2~*
>> ANQX         EXTEND+7
>> CHK          PSGOER+19*
>> COMQUIT      EXTEND+12*
   CURDAT       EXPOE+3~*,EXPOE+4
   CUTOFF       EXPIRED+7~*,EXPIRED+15*,EXPIRED+16*,EXPIRED+17*,EXPIRED+18*
                EXPIRED+19*,EXPIRED+20*,EXPIRED+21*,EXPIRED+27*,EXPIRED+28*
                EXPIRED+29*,EXPIRED+30*,EXPIRED+31*,EXPIRED+32*,EXPIRED+34
   D            PRNFREQ+1~
   DA           UNMARK+4*,DONE+1!,SPEED+4!*,MARK+2!*,UPDREN+1~,UPDREN+5*
                UPDREN+6!,UPDREN+8!*,UPDREN+16~*,UPDRENOE+2!*,PRNFREQ+1~
   DA(1         UNMARK+4*,SPEED+4*,MARK+2*,UPDREN+5*,UPDREN+6*,UPDREN+8*
                UPDREN+16*,UPDRENOE+2*
   DA(2         UPDREN+6*
   DD           UPDREN+1~,UPDREN+6!,UPDREN+8!
   DFN          EXTEND+7,UPDRENOE+2,EXPOE~,EXPOE+4,EXPIRED+7~*,EXPIRED+16
                EXPIRED+18,EXPIRED+22
   DIC          UPDREN+1~,UPDREN+6!*,UPDREN+8!
   DIC("DR"     UPDREN+7*
   DIC("P"      UPDREN+6*
   DIC(0        UPDREN+6*
   DIE          DONE+1!,UPDREN+1~,UPDREN+5*,UPDREN+6!,UPDREN+8!*,UPDREN+11
                UPDREN+16~*,UPDRENOE+2!*
>> DINUM        UPDREN+6*
   DIR          PSGOER+23!,UNMARK+1!,DONE+1!
   DIR("?"      PSGOER+24*,UNMARK+2*
   DIR("A"      PSGOER+23*,UNMARK+1*
   DIR("B"      PSGOER+23*,UNMARK+1*
   DIR(0        PSGOER+23*,UNMARK+1*
>> DIRUT        PSGOER+25,PSGOER+26,EXTEND+3*
   DO           UPDREN+1~,UPDREN+6!,UPDREN+8!
   DOWAT        NXTDOW~,NXTDOW+1
   DOWDFN       NXTDOW~,NXTDOW+1
   DOWFD        NXTDOW~,NXTDOW+1
   DOWSCH       NXTDOW~,NXTDOW+1
   DOWSD        NXTDOW~,NXTDOW+2
   DOWSTR       NXTDOW+1~*
   DR           DONE+1!,UPDREN+1~,UPDREN+2*,UPDREN+5*,UPDREN+6!,UPDREN+8!*
                UPDREN+10*,UPDREN+11*,UPDREN+16~*,UPDRENOE+2!*
   DTIME        READ+2
   DUOUT        EXTEND+1~,EXTEND+12,SPEED+2
   DUZ          MARK+2,UPDREN+7
   EXPDT        EXPOE~,EXPOE+4
   FDSD         DONE+1!
>> FILE         EXPOE+1*
   FREQ         EXPIRED+7~,EXPIRED+12*,EXPIRED+13*,EXPIRED+16,EXPIRED+17
                EXPIRED+20,EXPIRED+30*
   INTERVAL     EXPIRED+25~*,EXPIRED+26
   INTERVEN     NEWOC55+1~,NEWOC55+2*
   IOST         READ+1
   IVSTYP       EXPIRED+25~,EXPIRED+26*,EXPIRED+27,EXPIRED+28,EXPIRED+29
   LAST         EXPIRED+7~,EXPIRED+15*,EXPIRED+16*,EXPIRED+17,EXPIRED+19*
                EXPIRED+20,EXPIRED+27*,EXPIRED+28,EXPIRED+29,EXPIRED+30
                EXPIRED+31*,EXPIRED+32
   LASTAT       EXPIRED+7~
   LIMIT        EXPIRED+21~*
   LSTSTR       EXPIRED+7~,EXPIRED+14*,EXPIRED+16,EXPIRED+17,EXPIRED+18
                EXPIRED+20*,EXPIRED+25~,EXPIRED+26*,EXPIRED+32*
   LYN          EXPIRED+33!
   ND0          EXPIRED+12~*,EXPIRED+14,EXPIRED+15,EXPIRED+25~*,EXPIRED+26
                EXPIRED+27,EXPIRED+28,EXPIRED+31
>> ND14         UPDREN+6*
   ND2          EXPIRED+12~*,EXPIRED+14,EXPIRED+15,EXPIRED+16,EXPIRED+19
   NOW          EXPIRED+7~,EXPIRED+9*,EXPIRED+11,EXPIRED+15,EXPIRED+19
                EXPIRED+27,EXPIRED+28,EXPIRED+31,EXPIRED+34
   NXTADM       NXTDOW+1~*,NXTDOW+2
   P            EXPIRED+22~,EXPIRED+24
   P(           EXPIRED+22*
   P(11         EXPIRED+29
   P(2          EXPIRED+29
   P(4          EXPIRED+22,EXPIRED+23
   P(9          EXPIRED+29
   PSBCNT       EXPIRED+7~
   PSBDT        EXPIRED+33!
   PSBFLAG      EXPIRED+33!
   PSBSTR       EXPIRED+33!
   PSGAL        DONE+1!
   PSGAL("C"    UNMARK+4*,SPEED+4*,MARK+2*
   PSGALR       DONE+1!
   PSGAT        PSGOER+16,PSGOER+19,UPDREN+11,PRNFREQ+1~
>> PSGCANFL     PSGOER+25*,EXTEND+7*
>> PSGDDI       NEWOC55+3*,NEWOC55+4
   PSGDL        DONE+1!
   PSGDLS       DONE+1!
   PSGDRG       EXTEND+1~*,EXTEND+7
   PSGDT        EXTEND+9*,EXTEND+12,SPEED+5,MARK+2,MARK+3,NEWOC55+5,NEWOC55+7
                EXPIRED+7~,EXPIRED+9,EXPIRED+20,EXPIRED+32,PRNFREQ+1~
   PSGDW        EXPIRED+7~
   PSGFD        DONE+1!,SPEED+10
   PSGFOK       DONE+1!
   PSGFOK(106   EXTEND+12
   PSGND4       PSGOER+26*,UNMARK+4*,DONE+1!,EXTEND+9*,MARK+1,MARK+2*
>> PSGNESD      UPDREN+2*
   PSGOC        EXPIRED+7~
   PSGOEAV      SPEED+3~*
   PSGOEE       DONE+1!,EXTEND+10*
>> PSGOEENO     UPDREN+2*
>> PSGOEORD     UPDREN+3*,UPDREN+7
   PSGOEOS      EXTEND+10!
   PSGOEPR      SPEED+5,UPDREN~,UPDREN+2,UPDREN+7
   PSGOER0      DONE+1!
   PSGOER1      DONE+1!
   PSGOER2      DONE+1!
   PSGOERDP     DONE+1!,SPEED+10
   PSGOES       PRNFREQ+1~
   PSGOFD       SPEED+5,UPDREN~,UPDREN+2,UPDREN+7
   PSGOORD      UPDREN+1~,UPDREN+2*
>> PSGOPR       EXTEND+7
   PSGORD       PSGOER+13,PSGOER+26,UNMARK+4,EXTEND+1,EXTEND+2,EXTEND+9
                EXTEND+12,SPEED+1,SPEED+4,SPEED+5,SPEED+6,SPEED+7,MARK+2
                MARK+3*,MOVE+1,NEWOC55+3,NEWOC55+4,NEWOC55+13,UPDREN~,UPDREN+2
                UPDREN+3,UPDREN+5,UPDREN+6,UPDREN+8,UPDREN+10,UPDREN+11
                UPDREN+14,UPDREN+16,UPDRENOE~,UPDRENOE+1,UPDRENOE+2,UPDRENOE+3
                UPDRENOE+4
   PSGOREAS     EXTEND+1~
   PSGORQF      EXTEND+3*,NEWOC55+12!,NEWOC55+13
   PSGP         PSGOER+13,PSGOER+26,UNMARK+4,EXTEND+1,EXTEND+2,EXTEND+9
                EXTEND+10,EXTEND+12,SPEED+4,SPEED+5,SPEED+10,MARK+2,MOVE+1
                NEWOC55+3,NEWOC55+4,NEWOC55+12,UPDREN+3,UPDREN+5,UPDREN+6
                UPDREN+8,UPDREN+10,UPDREN+14,UPDREN+16,UPDRENOE~,UPDRENOE+1
                UPDRENOE+3,UPDRENOE+4
   PSGPOI       UPDREN+14~*,UPDREN+15
   PSGPOSA      DONE+1!,MARK+3*
   PSGPOSD      DONE+1!,MARK+3*
   PSGPR        DONE+1!,EXTEND+7~*,UPDREN+5
   PSGPX        DONE+1!
   PSGRD        DONE+1!
   PSGRFOUR     UPDREN+1~,UPDREN+10*
   PSGRZERO     UPDREN+1~,UPDREN+3*
   PSGS0XT      PSGOER+16,PSGOER+17*,PSGOER+19,PRNFREQ+1~,PRNFREQ+3
   PSGS0Y       PRNFREQ+1~
>> PSGSCH       PSGOER+16,PSGOER+17,PSGOER+21
   PSGSD        DONE+1!,UPDREN+2
   PSGST        PSGOER+18,EXTEND+2,PRNFREQ+1~
   PSGTOL       DONE+1!
   PSGTOO       DONE+1!
   PSGUOW       DONE+1!
   PSGWLL       DONE+1!,EXTEND+10*,SPEED+10
   PSJABT       EXTEND+1~
   PSJALLGY     NEWOC55+1~
   PSJALLGY(    NEWOC55+9*
   PSJALLGY(0   NEWOC55+10
>> PSJCOM       PSGOER+12
   PSJDD        NEWOC55+1~,NEWOC55+6*,NEWOC55+7,NEWOC55+9,NEWOC55+10*
                NEWOC55+11,NEWOC55+12,NEWOC55+13
   PSJDD0       NEWOC55+1~,NEWOC55+4*,NEWOC55+5,NEWOC55+6
   PSJDDI       NEWOC55+1~
   PSJEXPIR     PSGOER+13~*,PSGOER+14
   PSJEXPOE     EXPOE+4*!
   PSJIREQ      NEWOC55+1~,NEWOC55+2*
   PSJNOO       SPEED+5,UPDREN~,UPDREN+2*,UPDREN+5
   PSJNSS       PRNFREQ+1~
>> PSJORD       UPDREN+10
   PSJORDER     EXPOE~,EXPOE+1*,EXPOE+2,EXPOE+4
   PSJPDRG      NEWOC55+1~
   PSJPSTO      EXPIRED+7~
   PSJPWD       PRNFREQ+1~
   PSJREN       EXTEND+1~*
   PSJRXREQ     NEWOC55+1~,NEWOC55+2*
>> PSJSPEED     UPDREN+11
>> PSJSYSO      MARK+3
>> PSJSYSP      EXTEND+11,MOVE+1
>> PSJSYSP0     PSGOER+23,PSGOER+24,EXTEND+9
>> PSJSYSU      PSGOER+26,UNMARK+4,SPEED+1,SPEED+3,SPEED+4,UPDREN+10
>> PSJSYSW0     EXTEND+10,SPEED+10
   PSJX         NEWOC55+5*,NEWOC55+7*,NEWOC55+8,EXPIRED~,EXPIRED+7,EXPIRED+8
                EXPIRED+10,EXPIRED+12,EXPIRED+13,EXPIRED+15,EXPIRED+19
                EXPIRED+20,EXPIRED+25,EXPIRED+27,EXPIRED+31,EXPIRED+32
   PSJY         EXPIRED~,EXPIRED+8,EXPIRED+10,EXPIRED+12,EXPIRED+13,EXPIRED+15
                EXPIRED+19,EXPIRED+21,EXPIRED+22,EXPIRED+25,EXPIRED+27
                EXPIRED+31
>> Q            MOVE+1*,MOVE+2
   QX           PSGOER+17~
   RDATE        UPDRENOE~,UPDRENOE+1
   RDUZ         UPDREN~,UPDREN+7
   RF           DONE+1!
   RNWDT        UPDREN~,UPDREN+2,UPDREN+7,UPDREN+10
   SCHED        EXPIRED+13~*,EXPIRED+14,EXPIRED+17,EXPIRED+18,EXPIRED+25~*
                EXPIRED+26,EXPIRED+29,EXPIRED+30,PRNFREQ~,PRNFREQ+2
   SD           EXPIRED+7~
   SDW          PSGOER+17~
   ST           EXPIRED+7~
   STATUS       EXPIRED+7~,EXPIRED+8*
   STOP         EXPIRED+7~,EXPIRED+10*,EXPIRED+11,EXPIRED+21
   SWD          PSGOER+17~
   TEST         PRNFREQ+1~
   U            MOVE+2,NEWOC55+5,NEWOC55+7,UPDREN+15,EXPIRED+7~*,EXPIRED+10
                EXPIRED+22
   VALMBCK      EXTEND+12*,SPEED+11*,PRNFREQ+1~
   WD           EXPIRED+7~
   X            PSGOER+17~*,EXTEND+12,MOVE~,MOVE+1,NEWOC55+2*,UPDREN+7*,READ+2*
                EXPIRED+7~,PRNFREQ+1~,PRNFREQ+2*
   XABB         PSGOER+17~
   XP           EXPIRED+22~*
   Y            PSGOER+25,UNMARK+3,MOVE~,MOVE+1,MOVE+2,NEWOC55+2*
   YP           EXPIRED+22~*
   ZZND         EXPIRED+7~,PRNFREQ+1~,PRNFREQ+2

Global Variables  ( * Changed  ! Killed)
   ^PS(51.1            PSGOER+21
   ^PS(53.45           EXTEND+11!,MOVE+1*,MOVE+2*
   ^PS(55              PSGOER+26,UNMARK+4*,EXTEND+1,EXTEND+2,EXTEND+9,EXTEND+10
                       SPEED+10*,MARK+2*,MOVE+1,NEWOC55+3,NEWOC55+4,EXPIRED+8
                       EXPIRED+10,EXPIRED+12,EXPIRED+13,EXPIRED+22,EXPIRED+25
   ^PS(59.7            EXPIRED+21
   ^PSDRUG(            NEWOC55+7
   ^PSDRUG("ACLOZ"     EXTEND+7
   ^TMP("PSJDAOC"      SPEED+8!
   ^TMP("PSODAOC"      SPEED+6*,SPEED+8!

Naked Globals
   ^(           MOVE+1
   ^("I"        NEWOC55+7
   ^(2          EXTEND+11!,NEWOC55+7

Cache Objects
   NONE

Marked Items
   NONE

Label References
   $$EXPIRED    PSGOER+13
   $$NXTDOW     EXPIRED+18,EXPIRED+29
   $$PRNFREQ    EXPIRED+13,EXPIRED+30
   DONE         PSGOER+25,PSGOER+26,PSGOER+27,UNMARK+3,EXTEND+12
   EXPOE        UPDRENOE+1
   MARK         EXTEND+9
   MOVE         EXTEND+11
   NEW          PSGOER+25
   READ         EXTEND+3
   UNMARK       PSGOER+26
   UPDREN       SPEED+5
   UPDRENOE     SPEED+5

External References
   NOW^%DTC            EXTEND+9,EXPOE+3
   FILE^DICN           UPDREN+7
   ^DIE                UPDREN+5,UPDREN+12,UPDREN+16,UPDRENOE+2
   ^DIR                PSGOER+24,UNMARK+2
   $$EN^PSBAPIPM       EXTEND+2,EXPIRED+15,EXPIRED+19,EXPIRED+27,EXPIRED+31
   ^PSGAL5             UNMARK+4,SPEED+4,MARK+2
   ABORT^PSGOEE        PSGOER+27,UNMARK+3,EXTEND+12
   DATE^PSGOER0        EXTEND+12
   EN^PSGPEN           SPEED+1
   $$PRNOK^PSGS0       PSGOER+21
   DW^PSGS0            PSGOER+17
   ENDDC^PSGSICHK      NEWOC55+12
   ENPOS^PSGVDS        MARK+3
   $$DOW^PSIVUTL       PSGOER+21,EXPIRED+18,EXPIRED+26
   CLOZ^PSJCLOZ        EXTEND+7
   ^PSJCOMR            PSGOER+12
   EN1^PSJHL2          UPDRENOE+4,EXPOE+4
   $$SCHREQ^PSJLIVFD   EXPIRED+24
   PAUSE^PSJLMUT1      NEWOC55+11
   SETOC^PSJNEWOC      SPEED+7
   IN^PSJOCDS          NEWOC55+13
   ENUDTX^PSJOREN      UPDRENOE+3
   $$ENQ^PSJORP2       EXPIRED+20,EXPIRED+32,NXTDOW+1
   $$LASTAT^PSJORP2    EXPIRED+16
   ADMIN^PSJORPOE      PRNFREQ+2
   $$ACTIVE^PSJORREN   UPDREN+14
   $$DATE^PSJUTL2      EXPIRED+9
   $$DATE2^PSJUTL2     EXPOE+3
   $$LS^PSSLOCK        SPEED+5
   UNL^PSSLOCK         SPEED+5
   PAUSE^VALM1         PSGOER+15,PSGOER+20,PSGOER+22
   $$FMADD^XLFDT       EXPIRED+15,EXPIRED+16,EXPIRED+17,EXPIRED+19,EXPIRED+20
                       EXPIRED+21,EXPIRED+27,EXPIRED+28,EXPIRED+30,EXPIRED+31
                       EXPIRED+32,NXTDOW+1

*****   END   *****

   Press return to continue:

PSGOER0  * *  87 Lines,  5203 Bytes, Checksum: B24952711
                                                  Jun 01, 2016@09:50:20 page 10
              557 bytes in comments
PSGOER0  ;BIR/CML3 - EDIT FIELDS FOR RENEWAL ;12/09/07  02:22
         ;;5.0;INPATIENT MEDICATIONS;**11,45,47,50,63,64,70,69,58,80,110,127,136
          ,181,281,327**;16 DEC 97;Build 113
         ;
         ; Reference to ^PS(55 is supported by DBIA 2191. 
         ; Reference to ^VA(200 is supported by DBIA 10060.
         ; Reference to ^DD(55.06 is supported by DBIA 2253.
         ; Reference to ^%DT is supported by DBIA 10003.
         ; Reference to ^DIC is supported by DBIA 10006.
         ;
DATE(PSGP,PSGORD,PSGDT) --
          ;
         K PSGFOK,PSJNOO,PSGNEDFD,PSGOEPR,PSGOER0,PSGPDRG,PSGOER2,PSGWLL,PSGOERD
          P,PSGOFD,PSGPRN,PSGPRI,PSGOSD,PSGOPR,PSGRNSD,PSGS0XT,PSGS0Y,PSGST,PSGS
          CH,PSGSDN
         S F1=55.06,PSGWLL=+$G(^PS(55,PSGP,5.1)),PSGOER0=$G(^PS(55,PSGP,5,+PSGOR
          D,0)),PSGPDRG=+$G(^(.2)),PSGOER2=$G(^(2))
         NEW XX S XX=$$ACTIVE^PSJORREN(PSGP,PSGORD) S:+XX=2 PSGPDRG=$P(XX,U,2)
         I '+XX W !,"No active Orderable Item was found.",! G DONE
         S (PSGNEDFD,PSGOERDP)=$P($$GTNEDFD^PSGOE7("U",PSGPDRG),U)
         S PSGSCH=$P(PSGOER2,"^"),PSGST=$P(PSGOER0,"^",7),PSGS0Y=$P(PSGOER2,"^",
          5),PSGS0XT=$P(PSGOER2,"^",6)
         S PSGOEPR=+$P(PSGOER0,"^",2),(PSGOPR,PSGPR)=$S($P(PSJSYSU,";",2):DUZ,1:
          +PSGOEPR)
         I $G(PSJSPEED) S PSGPR=$S($P(ND,"^",2):$P(ND,"^",2),1:+PSGOEPR)
         S PSGOSD=+$P(PSGOER2,"^",2) S PSGOFD=+$P(PSGOER2,"^",4),PSGPRN=$P($G(^V
          A(200,PSGPR,0)),"^"),PSGPRI=$S($P(PSJSYSU,";",2):0,1:$P($G(^("PS")),"^
          ",4)),PSGRO=0 S:PSGPRI PSGPRI=PSGPRI'>DT I PSGPRI S (PSGOPR,PSGPR,PSGP
          RN)=""
         S PSGRNSD=$S($G(PSGLI):PSGLI,1:$G(PSGDT))
         S PSGSD=$G(PSGOSD)
         I PSGSD="" S PSJREN=1,PSGSD=$$ENSD^PSGNE3($S(PSGST["P":"PRN",1:$P(PSGOE
          R2,U)),PSGS0Y,PSGDT,PSGOSD) S:PSGOSD>PSGSD PSGSD=PSGOSD K PSJREN
         S PSGSDN=$$ENDD^PSGMI(PSGSD)
10       ;
         ;W !,"START DATE/TIME: "_PSGSDN
O25      ;
         N PSGSD,PSGNEFD S PSGSD=PSGDT
         D ENWALL^PSGNE3(PSGSD,0,PSGP)
         S:'$G(PSGDT) PSGDT=$$DATE2^PSJUTL2($$NOW^XLFDT)
         N PSGNESD S PSGNESD=PSGDT D ENFD^PSGNE3(PSGNESD) I $G(PSGNEFD) S (Y,PSG
          FD)=PSGNEFD
         S PSGFOK(10)="" I PSGST="O" S PSGFD=$$ENOSD^PSJDCU(PSJSYSW0,PSGRNSD,PSG
          P) I PSGFD]"" S Y=PSGRNSD,X=0 G 1
D25      K DUR,DURMIN N PKGFLG S PKGFLG=$S(PSGORD["U":5,PSGORD["V":"IV",PSGORD["
          P":"P",1:"") I PKGFLG]"" S DUR=$$GETDUR^PSJLIVMD(PSGP,+$G(PSGORD),PKGF
          LG,1) I DUR]"" D
         .S DURMIN=($$DURMIN^PSJLIVMD(DUR)\1) I DURMIN>1 S Y=$$FMADD^XLFDT(PSGRN
          SD,,,DURMIN) I Y>PSGRNSD S PSGFD=Y,X=0
         I $P($G(PSGOER2),"^",4)>PSGFD S Y=$P(PSGOER2,"^",4)
         I $G(DUR)]"",($G(PSGORD)'["P") S DURMIN=$$DURMIN^PSJLIVMD(DUR)\1 S Y=$$
          FMADD^XLFDT(PSGDT,,,DURMIN)
         S:X&$P(PSJSYSW0,"^",7) $P(Y,".",2)=$P(PSJSYSW0,"^",7) S PSGFD=+Y,PSGFDN
          =$$ENDD^PSGMI(PSGFD)
25       W !,"STOP DATE/TIME: "_PSGFDN_"// " R X:DTIME I X="^"!'$T W:'$T $C(7) S
          :'$T X="^" S PSGRO=1,COMQUIT=1 G DONE
         I X="" W "   "_PSGFDN G W25
         I $E(X)="^" D FF G:Y>0 @Y G 25
         S PSGF2=25 I X="@"!(X?1."?") W:X="@" $C(7),"  (Required)" S:X="@" X="?"
           D ENHLP^PSGOEM(55.06,25)
         I X=+X,X>0,X'>2000000 G 25:'$$ENDL^PSGDL(PSGSCH,X) K PSGDLS S PSGDL=X,N
          D2=PSGOER2,$P(ND2,"^",2)=PSGRNSD W " ...dose limit..." D ENGO^PSGDL
         K %DT S %DT="ERTX" D ^%DT K %DT G:Y'>0 25 S PSGFD=+Y,PSGFDN=$$ENDD^PSGM
          I(PSGFD)
W25      I PSGFD<PSGDT W $C(7),!!?13,"*** WARNING! THE STOP DATE ENTERED IS IN T
          HE PAST! ***",!
         I PSGFD<PSGSD W $C(7),!!?3,"*** The STOP date must be AFTER the START d
          ate. ***" G 25
         S PSGFOK(25)=""
         ;Display Expected First Dose;BHW;PSJ*5*136
         D EFDNEW^PSJUTL
         I $G(PSGONF),(+$G(PSGODDD(1))'<+$G(PSGONF)) S PSGFOK(1)="" Q
1        ; provider
         G:+PSJSYSU<3&$P(PSJSYSU,";",2) CHKDD S PSGF2=1
A1       ;
         S PSTMPI=PSGPR,PSTMPN=PSGPRN
         W !,"PROVIDER: ",$S(PSGPR:PSGPRN_"// ",1:"") R X:DTIME I X="^"!'$T W:'$
          T $C(7) S:'$T X="^" S PSGRO=1,COMQUIT=1 G DONE
         I $S(X="":'PSGPR,1:X="@") W $C(7),"  (Required)" S X="?" D ENHLP^PSGOEM
          (55.06,1) G A1
         I X="",PSGPR S X=PSGPRN I PSGPR'=PSGPRN,$D(^VA(200,PSGPR,"PS")) W "    
          "_$P(^("PS"),"^",2)_"    "_$P(^("PS"),"^",3) S PSGFOK(1)="" G:'$G(ANOX
          ) OC55
         I X?1."?" D ENHLP^PSGOEM(55.06,1)
         I $E(X)="^" D FF G:Y>0 @Y G A1
         K DIC S DIC="^VA(200,",DIC(0)="EMQZ",DIC("S")="S X(1)=$G(^(""PS"")) I X
          (1),$S('$P((X(1)),""^"",4):1,1:DT<$P((X(1)),""^"",4))" D ^DIC K DIC I 
          Y'>0 G A1
         S PSGPR=+Y,PSGPRN=$P(Y(0,0),"^"),PSGFOK(1)=""
         ;; START NCC T4 MODS >> 327*RJS
A2       D CLOZPRV^PSGOE82
         I $G(ANQX) W ! S PSGPR=PSTMPI,PSGPRN=PSTMPN  K PSTMPN,PSTMPI G A1
         K ANQX
         ;; END NCC T4 MODS << 327*RJS
OC55     ;
         ;Order check for Speed finish is triggered from OC531^PSGOESF
         I $G(PSGORD)]"P",$G(PSJSPEED) Q
         I $G(PSJOCFG)="SPEED RENEW" G CHKDD
         D NEWOC55^PSGOER
         I $G(PSGORQF) S COMQUIT=1 G DONE
CHKDD    ;
         G:$G(PSGRENEW) 106
         I PSGORD["P"!$$DDOK^PSGOE2("^PS(55,"_PSGP_",5,"_+PSGORD_",1,",PSGPDRG) 
          G 106
         ;I PSGORD["P"!'$$CHKDD^PSGOE2("^PS(55,"_PSGP_",5,"_+PSGORD_",") G 106
         I $P(PSJSYSU,";")'=3,'$P(PSJSYSP0,U,2) W !!,"This order's dispense drug
           is invalid, a pharmacist must renew this order." Q
         K ^PS(53.45,PSJSYSP,1),^(2)
         W !!,"THE DISPENSE DRUG IS MISSING FROM THIS ORDER."
         D ENDRG^PSGOEF1(+^PS(55,PSGP,5,+PSGORD,.2),0)
         I $G(DUOUT)!'$G(DRG) S COMQUIT=1 Q
106      ; nature of order
         S PSJNOO=$$ENNOO^PSJUTL5("R") S:PSJNOO<0 COMQUIT=1
         S:PSJNOO'<0 PSGFOK(106)=""
DONE     ;
         K F,F0,F1,PSGF2,F3,ND2,PSGDL,PSGDLS,PSGOROE1,PSGRO,SDT,X,Y Q
FF       ; "^" to another field
         K DIC S DIC="^DD(55.06,",DIC(0)="EQ",DIC("S")="I $D(PSGFOK(+Y))",X=$E(X
          ,2,255) D ^DIC K DIC
         S Y=+Y Q

*****   INDEX OF PSGOER0   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
   %DT          25+5!*
>> ANOX         A1+4
   ANQX         A2+1,A2+2!
>> COMQUIT      25*,A1+2*,OC55+5*,CHKDD+8*,106+1*
   DIC          A1+7!*,FF+1!*
   DIC("S"      A1+7*,FF+1*
   DIC(0        A1+7*,FF+1*
>> DRG          CHKDD+8
   DT           DATE+9
   DTIME        25,A1+2
>> DUOUT        CHKDD+8
   DUR          D25!*,D25+1,D25+3
   DURMIN       D25!,D25+1*,D25+3*
   DUZ          DATE+7
   F            DONE+1!
   F0           DONE+1!
   F1           DATE+2*,DONE+1!
   F3           DONE+1!
>> ND           DATE+8
   ND2          25+4*,DONE+1!
   PKGFLG       D25~*
   PSGDL        25+4*,DONE+1!
   PSGDLS       25+4!,DONE+1!
   PSGDT        DATE~,DATE+10,DATE+12,O25+1,O25+3*,O25+4,D25+3,W25
   PSGF2        25+3*,1+1*,DONE+1!
>> PSGFD        O25+4*,O25+5*,D25+1*,D25+2,D25+4*,25+5*,W25,W25+1
>> PSGFDN       D25+4*,25,25+1,25+5*
   PSGFOK       DATE+1!
   PSGFOK(1     W25+5*,A1+4*,A1+8*
   PSGFOK(10    O25+5*
   PSGFOK(106   106+2*
   PSGFOK(25    W25+2*
>> PSGLI        DATE+10
   PSGNEDFD     DATE+1!,DATE+5*
   PSGNEFD      O25+1~,O25+4
   PSGNESD      O25+4~*
>> PSGODDD(1    W25+5
   PSGOEPR      DATE+1!,DATE+7*,DATE+8
   PSGOER0      DATE+1!,DATE+2*,DATE+6,DATE+7
   PSGOER2      DATE+1!,DATE+2*,DATE+6,DATE+9,DATE+12,D25+2,25+4
   PSGOERDP     DATE+1!,DATE+5*
   PSGOFD       DATE+1!,DATE+9*
>> PSGONF       W25+5
   PSGOPR       DATE+1!,DATE+7*,DATE+9*
   PSGORD       DATE~,DATE+2,DATE+3,D25,D25+3,OC55+2,CHKDD+2,CHKDD+7
   PSGOROE1     DONE+1!
>> PSGORQF      OC55+5
   PSGOSD       DATE+1!,DATE+9*,DATE+11,DATE+12
   PSGP         DATE~,DATE+2,DATE+3,O25+2,O25+5,D25,CHKDD+2,CHKDD+7
   PSGPDRG      DATE+1!,DATE+2*,DATE+3*,DATE+5,CHKDD+2
>> PSGPR        DATE+7*,DATE+8*,DATE+9*,A1+1,A1+2,A1+3,A1+4,A1+8*,A2+1*
   PSGPRI       DATE+1!,DATE+9*
   PSGPRN       DATE+1!,DATE+9*,A1+1,A1+2,A1+4,A1+8*,A2+1*
>> PSGRENEW     CHKDD+1
   PSGRNSD      DATE+1!,DATE+10*,O25+5,D25+1,25+4
   PSGRO        DATE+9*,25*,A1+2*,DONE+1!
   PSGS0XT      DATE+1!,DATE+6*
   PSGS0Y       DATE+1!,DATE+6*,DATE+12
   PSGSCH       DATE+1!,DATE+6*,25+4
   PSGSD        DATE+11*,DATE+12*,DATE+13,O25+1~*,O25+2,W25+1
   PSGSDN       DATE+1!,DATE+13*
   PSGST        DATE+1!,DATE+6*,DATE+12,O25+5
   PSGWLL       DATE+1!,DATE+2*
   PSJNOO       DATE+1!,106+1*,106+2
>> PSJOCFG      OC55+3
   PSJREN       DATE+12*!
>> PSJSPEED     DATE+8,OC55+2
>> PSJSYSP      CHKDD+5
>> PSJSYSP0     CHKDD+4
>> PSJSYSU      DATE+7,DATE+9,1+1,CHKDD+4
>> PSJSYSW0     O25+5,D25+4
   PSTMPI       A1+1*,A2+1!
   PSTMPN       A1+1*,A2+1!
   SDT          DONE+1!
   U            DATE+3,DATE+5,DATE+12,CHKDD+4
   X            O25+5*,D25+1*,D25+4,25*,25+1,25+2,25+3*,25+4,A1+2*,A1+3*,A1+4*
                A1+5,A1+6,DONE+1!,FF+1*
   XX           DATE+3~*,DATE+4
   Y            O25+4*,O25+5*,D25+1*,D25+2*,D25+3*,D25+4*,25+2,25+5,A1+6,A1+7
                A1+8,DONE+1!,FF+2*
   Y(0          A1+8

Global Variables  ( * Changed  ! Killed)
   ^PS(53.45           CHKDD+5!
   ^PS(55              DATE+2,CHKDD+7
   ^VA(200             DATE+9,A1+4

Naked Globals
   ^(           DATE+2
   ^("PS"       DATE+9,A1+4
   ^(2          DATE+2,CHKDD+5!

Cache Objects
   NONE

Marked Items
   NONE

Label References
   1            O25+5
   25           25+2,25+4,25+5,W25+1
   106          CHKDD+1,CHKDD+2
   @(           25+2,A1+6
   A1           A1+3,A1+6,A1+7,A2+1
   CHKDD        1+1,OC55+3
   DONE         DATE+4,25,A1+2,OC55+5
   FF           25+2,A1+6
   OC55         A1+4
   W25          25+1

External References
   ^%DT                25+5
   ^DIC                A1+7,FF+1
   $$ENDL^PSGDL        25+4
   ENGO^PSGDL          25+4
   $$ENDD^PSGMI        DATE+13,D25+4,25+5
   $$ENSD^PSGNE3       DATE+12
   ENFD^PSGNE3         O25+4
   ENWALL^PSGNE3       O25+2
   $$DDOK^PSGOE2       CHKDD+2
   $$GTNEDFD^PSGOE7    DATE+5
   CLOZPRV^PSGOE82     A2
   ENDRG^PSGOEF1       CHKDD+7
   ENHLP^PSGOEM        25+3,A1+3,A1+5
   NEWOC55^PSGOER      OC55+4
   $$ENOSD^PSJDCU      O25+5
   $$DURMIN^PSJLIVMD   D25+1,D25+3
   $$GETDUR^PSJLIVMD   D25
   $$ACTIVE^PSJORREN   DATE+3
   EFDNEW^PSJUTL       W25+4
   $$DATE2^PSJUTL2     O25+3
   $$ENNOO^PSJUTL5     106+1
   $$FMADD^XLFDT       D25+1,D25+3
   $$NOW^XLFDT         O25+3

*****   END   *****

   Press return to continue:

PSGOEV   * *  195 Lines,  12137 Bytes, Checksum: B92599651
                                                  Jun 01, 2016@09:50:20 page 11
              1756 bytes in comments
PSGOEV   ;BIR/CML3 - VERIFY (MAKE ACTIVE) ORDERS ;4/16/10 9:18am
         ;;5.0;INPATIENT MEDICATIONS;**5,7,15,28,33,50,64,58,77,78,80,110,111,13
          3,171,207,241,267,268,260,288,199,281,327**;16 DEC 97;Build 113
         ;
         ; Reference to ^ORD(101 supported by DBIA #872.
         ; Reference to ^PS(50.7 supported by DBIA #2180.
         ; Reference to ^PS(55 supported by DBIA #2191.
         ; Reference to ^PSSLOCK supported by DBIA #2789.
         ; Reference to ^PSDRUG( supported by DBIA# 2192.
         ; Reference to MAIN^TIUEDIT is supported by DBIA #2410.
         ; Reference to ^TMP("PSODAOC",$J supported by DBIA 6071
         ;
EN(PSGORD) --
          ;
ENSF     ; This entry point is used by Speed finish only.
         ; Send SN update to CPRS if auto-verify off and from Order Set entry
         S:'$D(PSGOEAV) PSGOEAV=$P($G(PSJSYSP0),"^",9)&$G(PSJSYSU)
         I $D(PSGOES),'PSGOEAV,PSGORD["P",$P($G(^PS(53.1,+PSGORD,0)),"^",21)']""
           D ORSET^PSGOETO1
         D FULL^VALM1 I 'PSJSYSU W $C(7),$C(7),!!," THIS FUNCTION NOT AVAILABLE 
          TO WARD STAFF." Q
         S CHK=0 I PSGORD["P" S X=$P($G(^PS(53.1,+PSGORD,0)),"^",19) I X,$D(^PS(
          55,PSGP,5,$P(^(0),"^",19))) S CHK=+PSGORD,PSGORD=X_"U" L -^PS(53.1,CHK
          ) L +^PS(55,PSGP,5,+PSGORD):1 E  W !!,"Another terminal is editing thi
          s order." G DONE
         I +PSJSYSU=3 D DDCHK G:CHK DONE
         I PSGORD["P" D CHK($G(^PS(53.1,+PSGORD,0)),$G(^(.2)),$G(^(2)))
         I $G(PSGSCH)]"" D
         .N X,Y,PSGS0Y,PSGS0XT,PSGOES S PSGOES=1 S X=PSGSCH D ENOS^PSGS0 I $G(X)
          ="" S CHK=4
         I $G(CHK) Q:$D(PSJSPEED)  D EN^VALM("PSJU LM ACCEPT") G:'$G(PSJACEPT) D
          ONE ;G VFY
         I PSGORD["U" G:'$D(^PS(55,PSGP,5,+PSGORD,4)) VFY I +PSJSYSU=3,$P(^(4),"
          ^",3) W $C(7),!!,"THIS ORDER HAS ALREADY BEEN VERIFIED BY A PHARMACIST
          ." S PSGACT=$P(PSGACT,"V")_$P(PSGACT,"V",2) G DONE
         I PSGORD["U" I +PSJSYSU=1,+^PS(55,PSGP,5,+PSGORD,4) W $C(7),!!,"THIS OR
          DER HAS ALREADY BEEN VERIFIED BY A NURSE." S PSGACT=$P(PSGACT,"V")_$P(
          PSGACT,"V",2) G DONE
         ;
VFY      ; change status, move to 55, and change label record **ENHANCEMENTS MAD
          E IN PSJ*5.0*260 **CCR 6214 **CCR 6244
         I PSGORD["P" S PSJCOM=+$P($G(^PS(53.1,+PSGORD,.2)),"^",8) I PSJCOM D VF
          Y^PSJCOM Q
         NEW PSJDOSE,PSJDSFLG,PSJDIS,PSGORQF,PSJCNT,PSJCNT1,PSJCNT2,LIST,PSJFLG,
          PSGDN SET PSJDIS="",PSJCNT=0,PSJCNT1="",PSJCNT2="",LIST="PSGPRE",PSJFL
          G="",PSGDN=""
         D DOSECHK^PSJDOSE
         SET PSJFLG=+$G(PSGORD)
         FOR  SET PSJCNT=$O(^PS(53.1,PSJFLG,1,PSJCNT)) Q:'+PSJCNT  D
         .IF $D(^PS(53.1,PSJFLG,1,PSJCNT,0)) SET PSGDN=$P($G(^PS(53.1,PSJFLG,1,P
          SJCNT,0)),U,1)
         .IF +$G(PSGDN),($P($G(^PSDRUG(PSGDN,0)),U,3)'["S")&($E($P($G(^PSDRUG(PS
          GDN,0)),U,2),1,2)'="XA")  D
         ..D PROFILE^PSJBLDOC($G(DFN),LIST,"I;"_$G(PSGORD))
         ..FOR  SET PSJCNT1=$O(^TMP($J,LIST,"IN","PROFILE",PSJCNT1)) Q:(PSJCNT1=
          "")!(PSJDIS'="")  D
         ...SET PSJCNT2=$P(PSJCNT1,";",2)
         ...IF PSJCNT2=$G(PSGORD) SET PSJDIS=$P(^TMP($J,LIST,"IN","PROFILE",PSJC
          NT1),U,3)
         ..;**Do order checks if PSJDIS (Dispense drug IEN) has a value
         ..;IF $G(PSJNEWOE)=0,'$G(PSJLMFIN),'$G(PSJSTARI),'$G(PSGCOPY),$G(PSJDIS
          ),'$G(PSJSPEED)  D
         ..IF '+$G(PSJNEWOE),'$G(PSJLMFIN),'$G(PSJSTARI),'$G(PSGCOPY),$G(PSJDIS)
          ,'$G(PSJSPEED)  D
         ...D ALLERGY($G(PSJORD),.PSJALLGY),ENDDC^PSGSICHK($G(PSGP),PSJDIS) D:('
          $G(PSGORQF)&'$G(PSJDSVFY)&'$G(PSJSTARI)) IN^PSJOCDS($G(PSGORD),"UD",PS
          JDIS) IF $G(PSGORQF) K ^TMP($J,LIST) D:$G(PSJORD)]"" EN^VALM("PSJ LM U
          D ACTION") QUIT
         IF $G(PSGORQF) QUIT
         D FULL^VALM1 ;PSJ*5*241
         I +$G(PSJDSFLG) D SETVAR^PSJDOSE W !!,PSJDOSE("WARN"),!,PSJDOSE("WARN1"
          ) I '$$CONT() W !,"...order was not verified..." D PAUSE^VALM1 D  Q:'$
          G(PSJACEPT)
         . S PSGOEEF(109)=1
         . S PSJACEPT=0
         . ;D EN^VALM("PSJU LM ACCEPT")
         D DDCHK G:CHK DONE
         I $G(PSGSCH)]"",((",P,R,")'[(","_PSGST_",")) D  I CHK G DONE
         .N SWD,SDW,XABB,X,QX S X=$G(PSGSCH) D DW^PSGS0 Q:($G(X)="")  I $G(PSGS0
          XT)="" S PSGS0XT="D"
         .I $G(PSGS0XT)="D",$G(PSGAT)="" S CHK=1 W !!,"This is a 'DAY OF WEEK' s
          chedule and MUST have admin times.",! D PAUSE^VALM1
         I $G(PSGSCH)]"" D  I CHK G DONE
         .N X,Y,PSGS0XT,PSGS0Y,PSGOES S PSGOES=2,X=PSGSCH D ENOS^PSGS0 I $G(X)="
          " S CHK=4
         W !,"...a few moments, please..."
         I PSGORD["P" D
         . N PND0,PSGORDR,PSJPRIO,PSJSCHED S PND0=^PS(53.1,+PSGORD,0) I $P(PND0,
          U,24)="R" S PSGORDR=$P(PND0,U,25) D  Q
         .. N OEORD,OOEORD,FILE55,FILE55N0 S FILE55="^PS(55,"_DFN_$S($P(PND0,U,4
          )="U":",5,",1:",""IV"","),FILE55N0=FILE55_+PSGORDR_",0)"
         .. S OEORD=$P(PND0,U,21) I PSGORDR S OOEORD=$P(@FILE55N0,"^",21) I OEOR
          D'=OOEORD D EXPOE^PSGOER(DFN,PSGORD,+$$LASTREN^PSJLMPRI(DFN,PSGORD))
         .. S PSGORDP=PSGORD,DIE="^PS(53.1,",DA=+PSGORD,DR="28////A;104////@" W 
          "." D ^DIE
         .. D START^PSGOTR(PSGORD,+PSGORDR) I OEORD D
         ... K DA,DR,DIE S DA(1)=DFN,DA=+PSGORDR,DIE=FILE55,DR=$S(DIE["IV":110,1
          :66)_"////"_+OEORD D ^DIE S DIE=FILE55_+PSGORDR_",0)",$P(@DIE,U,21)=OE
          ORD
         ... D EN1^PSJHL2(DFN,"SC",PSGORDR),EN^PSGPEN(PSGORDR),UNL^PSSLOCK(PSGP,
          PSGORDR)
         . S PSGORDP=PSGORD ;Used in ACTLOG to update activity log in 55
         . D REQDT^PSJLIVMD(PSGORD)
         . S DIE="^PS(53.1,",DA=+PSGORD,DR="28////A" W "." D ^DIE,^PSGOT
         . S PSJPRIO=$S(PSGORD["P":$P($G(^PS(53.1,+PSGORD,.2)),"^",4),PSGORD["U"
          :$P($G(^PS(55,DFN,5,+PSGORD,.2)),"^",4),1:$P($G(^PS(55,PSJHLDFN,"IV",+
          PSGORD,.2)),"^",4))
         . S PSJSCHED=$S(PSGORD["P":$P($G(^PS(53.1,+PSGORD,2)),"^"),PSGORD["U":$
          P($G(^PS(55,DFN,5,+PSGORD,2)),"^"),1:$P($G(^PS(55,PSJHLDFN,"IV",+PSGOR
          D,0)),"^",15))
         . I (",S,A,")[(","_$G(PSJPRIO)_",")!($G(PSJSCHED)="NOW")!($G(PSJSCHED)[
          "STAT") D NOTIFY^PSJHL4(PSGORD,DFN,$G(PSJPRIO),$G(PSJSCHED))
         . I $G(PSGRDTX)="" S PSGRDTX=$G(^PS(53.1,+PSGORDP,2.5))
         S DA=+PSGORD,DA(1)=PSGP,PSGAL("C")=PSJSYSU*10+22000 D ^PSGAL5 W "." S V
          ND4=$G(^PS(55,PSGP,5,DA,4))
         I $G(PSGRDTX) D NEWUDAL^PSGAL5(PSGP,PSGORD,6090,"Requested Start Date",
          +$G(PSGRDTX))
         I $P($G(PSGRDTX),U,3) D NEWUDAL^PSGAL5(PSGP,PSGORD,6090,"Requested Stop
           Date",+$P($G(PSGRDTX),U,3))
         N DUR,DURON S DURON=$S($G(PSGORD):$G(PSGORD),1:"") I DURON D
         . S DUR=$S($P($G(PSGRDTX),U,2)]"":$P($G(PSGRDTX),U,2),1:$$GETDUR^PSJLIV
          MD(PSGP,+DURON,$S($G(DURON)["P":"P",1:5),1),1:"")
         I $G(DUR)]"" S $P(^PS(55,PSGP,5,+PSGORD,2.5),"^",2)=DUR
         D:$D(PSGORDP) ACTLOG(PSGORDP,PSGP,PSGORD)
         K PSGRSD,PSGRFD,PSGALFN
         NEW X S X=0 I $G(PSGONF),(+$G(PSGODDD(1))'<+$G(PSGONF)) S X=1
         I +PSJSYSU=3,PSGORD'["O",$S(X:0,'$P(VND4,"^",9):1,1:$P(VND4,"^",15)) D 
          EN^PSGPEN(+PSGORD)
         S $P(VND4,"^",+PSJSYSU=1+9)=1 S:'$P(VND4,U,+PSJSYSU=3+9) $P(VND4,U,+PSJ
          SYSU=3+9)=+$P(VND4,U,+PSJSYSU=3+9)
         I PSJSYSL>1 S $P(^PS(55,PSGP,5,+PSGORD,7),U)=PSGDT S:$P(^(7),U,2)="" $P
          (^(7),U,2)="N"_$S($P(^PS(55,PSGP,5,+PSGORD,0),"^",24)="E":"E",1:"") S 
          PSGTOL=2,PSGUOW=DUZ,PSGTOO=1,DA=+PSGORD D ENL^PSGVDS
         S:$P(VND4,"^",15)&'$P(VND4,"^",16) $P(VND4,"^",15)="" S:$P(VND4,"^",18)
          &'$P(VND4,"^",19) $P(VND4,"^",18)="" S:$P(VND4,"^",22)&'$P(VND4,"^",23
          ) $P(VND4,"^",22)="" S $P(VND4,"^",PSJSYSU,PSJSYSU+1)=DUZ_"^"_PSGDT,^P
          S(55,PSGP,5,+PSGORD,4)=VND4
         I '$P(VND4,U,9) S ^PS(55,"APV",PSGP,+PSGORD)=""
         I '$P(VND4,U,10) S ^PS(55,"ANV",PSGP,+PSGORD)=""
         I $P(VND4,U,9) K ^PS(55,"APV",PSGP,+PSGORD)
         I $P(VND4,U,10) K ^PS(55,"ANV",PSGP,+PSGORD)
         W:'$D(PSJSPEED) ! W !,"ORDER VERIFIED.",!
         I '$D(PSJSPEED) K DIR S DIR(0)="E" D ^DIR K DIR
         S:+PSJSYSU=3 ^PS(55,"AUE",PSGP,+PSGORD)="" S PSGACT="C"_$S('$D(^PS(55,P
          SGP,5,+PSGORD,4)):"E",$P(^(4),"^",16):"",1:"E")_"RS",PSGCANFL=2
         S VALMBCK="Q" D EN1^PSJHL2(PSGP,$S(+PSJSYSU=3:"SC",+PSJSYSU=1:"SC",1:"X
          X"),+PSGORD_"U")     ; allow status change to be sent for pharmacists 
          & nurses
         S ^TMP("PSODAOC",$J,"IP IEN")=$G(PSJORD),^TMP("PSODAOC",$J,"IP NEW IEN"
          )=$G(PSGORD)
         ; -- RTC 198753 - clean-up variable - K PSJAGYSV
         D SETOC^PSJNEWOC(PSGORD) K PSJAGYSV
          ; **This is where the Automated Dispensing Machine hook is called. Do 
          NOT DELETE or change this location **
         ;; START NCC REMEDIATION >> 327*RJS
         D NEWJ^PSJADM,CLOZSND^PSJOE
         ;; END NCC REMEDIATION << 327*RJS
         ; **END of Interface hook **
          ; **END of Interface hook **
         D:+PSJSYSU=1 EN1^PSJHL2(PSGP,"ZV",+PSGORD_"U")
DONE     ;
         W:CHK !!,"...order NOT verified..."
         I '$D(PSJSPEED),'CHK,+PSJSYSU=3,$G(PSJPRI)="D" D
         .N DIR W ! S DIR(0)="S^Y:Yes;N:No",DIR("A")="Do you want to enter a Pro
          gress Note",DIR("B")="No" D ^DIR
         .Q:Y="N"
         .D MAIN^TIUEDIT(3,.TIUDA,PSGP,"","","","",1)
         S VALMBCK="Q" K CHK,DA,DIE,F,DP,DR,ND,PSGAL,PSGODA,PSGTOL,PSGTOO,PSGUOW
          ,PSJDOSE,PSJVAR,VND4,X,ZZND Q
         ;
LBL      ;
         Q
         ;
ALLERGY(PSGORD,PSJALLGY) --
          ;setup PSJALLGY when non-vf was selected to verify
         NEW PSGDDI,PSJDD,PSJX
         I '+$G(PSGORD),($G(PSGORD)'["P") Q
         F PSGDDI=0:0 S PSGDDI=$O(^PS(53.1,+PSGORD,1,PSGDDI)) Q:'PSGDDI  D
         . S PSJDD=+$G(^PS(53.1,+PSGORD,1,PSGDDI,0))
         . S PSJX=$S('$D(^PSDRUG(+PSJDD,0)):1,$P($G(^(2)),U,3)'["U":1,$G(^("I"))
          ="":0,1:^("I")'>$G(DT))
         . Q:PSJX
         . S PSJALLGY(PSJDD)=""
         Q
CHK(ND,DRG,ND2) --
          ; checks for data in required fields
         ; Input: ND  - ^(PS(53.1,PSGORD,0)
         ;        DRG - ^(.2)
         ;        ND2 - ^(2)
         S Y=$G(Y)
         S CHK="" I DRG,$D(^PS(50.7,+DRG,0))
         E  S CHK=1
         I ND="" S CHK=CHK_23
         E  S CHK=CHK_$S($P(ND,"^",3):"",1:2)_$S($P(ND,"^",7)]"":"",1:3)
         ;The naked reference on the line below refers to the variable ND which 
          is ^PS(53.1,PSGORD,0).
         I ND2="" S CHK=CHK_$S('$D(^(0)):4,$P(^(0),"^",7)="OC":"",1:4)_56
         E  S CHK=CHK_$S($P(ND2,"^")]"":"",ND="":4,$P(ND,"^",7)="OC":"",1:4)_$S(
          $P(ND2,"^",2):"",1:5)_$S($P(ND2,"^",4):"",1:6)
         I $$CHECK^PSGOE8(PSJSYSP),$P(DRG,U,2)="" S CHK=CHK_8
         K PSGDFLG,PSGPFLG S PSGDI=0
         S:'$$DDOK^PSGOE2("^PS(53.45,"_PSJSYSP_",2,",+DRG) CHK=CHK_7,(PSGDFLG,PS
          GDI)=1
         S:'$$OIOK^PSGOE2(+DRG) PSGPFLG=1
         I 'CHK,$G(PSGSCH)]"" D
         .N X,Y,PSGS0Y,PSGS0XT,PSGOES S PSGOES=2,X=PSGSCH D ENOS^PSGS0 I $G(X)="
          " S CHK=4
         Q:'CHK
         W $C(7)
         ;
CHKM     ;
         D FULL^VALM1 K:CHK Y
         ; changed to remove ^DD ref
         ; PSJ*5*267 VMP Add the 8th condition
         W !!,"THE FOLLOWING ",$S($L(CHK)>1:"ARE",1:"IS")," EITHER INVALID OR MI
          SSING FROM THIS ORDER:" F X=1:1:8 W:CHK[X !?5,$P("ORDERABLE ITEM^MED R
          OUTE^SCHEDULE TYPE^SCHEDULE^START DATE/TIME^STOP DATE/TIME^DISPENSE DR
          UG^DOSAGE ORDERED","^",X)
         I CHK=7 W !,"Orders with no dispense drugs or multiple dispense drugs",
          !,"require dosage ordered"
         W:CHK]"" !!,$S($L(CHK)>1:"THESE FIELDS ARE",1:"THIS FIELD IS")," NECESS
          ARY FOR VERIFICATION."
         N DIR,DUOUT,DTOUT S DIR(0)="E" D ^DIR I $D(DUOUT)!$D(DTOUT) S CHK=1 Q
         Q
         ;
CONT()   ;
         NEW DIR,DIRUT,Y
         W ! K DIR,DIRUT
         S DIR(0)="Y",DIR("A")="Would you like to continue verifying the order",
          DIR("B")="No"
         D ^DIR
         Q Y
         ;
DDCHK    ; dispense drug check
         S DRGF="^PS("_$S(PSGORD["P":"53.1,"_+PSGORD,1:"55,"_PSGP_",5,"_+PSGORD)
          _",",CHK=$S('$O(@(DRGF_"1,0)")):7,1:0)
         S PSGPD=$G(@(DRGF_".2)"))
         S CHK=$S('$$DDOK^PSGOE2(DRGF_"1,",PSGPD):7,1:0)
         Q:CHK=0
         W $C(7),!!,"This order must have at least one valid, active dispense dr
          ug to be verified."
         ;
DDEDIT   ;
         ;*** Remove all dispense drug for this order
         K @(DRGF_"1)")
         ; The naked reference below refers to the indirect full reference in DR
          GF_"1,"_Q_")", which is either ^PS(53.1,+PSGORD,Q) or ^PS(55,DFN,5,+PS
          GORD,Q)
         K ^PS(53.45,PSJSYSP,2) S (X,Q)=0 F  S Q=$O(@(DRGF_"1,"_Q_")")) Q:'Q  S 
          Y=$G(^(Q,0)),X=Q S ^PS(53.45,PSJSYSP,2,Q,0)=Y I Y S ^PS(53.45,PSJSYSP,
          2,"B",+Y,Q)=""
         I X S ^PS(53.45,PSJSYSP,2,0)="^53.4502P^"_X_"^"_X
         D ENDRG^PSGOEF1(PSGPD,X)
         I 'CHK S %X="^PS(53.45,"_PSJSYSP_",2,",%Y=DRGF_"1," D %XY^%RCR S $P(@(D
          RGF_"1,0)"),"^",2)=$S(DRGF[53.1:"53.11P",1:"55.07P")
         K DRG,DRGF,%X,%Y,PSGPD Q
         ;
AESCREEN() --
          ;
         ; Output: 0 - Required fields missing and DON'T allow accept
         ;         1 - Required fields found.
         Q:'$G(CHK) 1
         S Y=$P($G(^ORD(101,+$G(^ORD(101,DA(1),10,DA,0)),0)),U) I Y="" Q 0
         I Y="PSJU LM ACCEPT EDIT" Q 1
         Q 0
ACTLOG(PSGORDP,DFN,PSGORD) --
           ;Store 53.1 activity log in local array to be moved to 55
         ;PSGORDP: IEN from 53.1
         ;PSGORD : IEN from 55
         NEW PSGX,PSGXDA,PSGAL531,Q,QQ
         F PSGX=0:0 S PSGX=$O(^PS(53.1,+PSGORDP,"A",PSGX)) Q:'PSGX  D
         . S PSGAL531=$G(^PS(53.1,+PSGORDP,"A",PSGX,0))
         . S QQ=$G(^PS(55,DFN,5,+PSGORD,9,0)) S:QQ="" QQ="^55.09D" F Q=$P(QQ,U,3
          )+1:1 I '$D(^(Q)) S $P(QQ,U,3,4)=Q_U_Q,^(0)=QQ,PSGXDA=Q Q
         . S ^PS(55,DFN,5,+PSGORD,9,PSGXDA,0)=PSGAL531
         . N TXTLN S TXTLN="" F  S TXTLN=$O(^PS(53.1,+PSGORDP,"A",PSGX,1,TXTLN))
           Q:TXTLN=""  D
         .. I TXTLN=0 S ^PS(55,DFN,5,+PSGORD,9,PSGXDA,1,TXTLN)=^PS(53.1,+PSGORDP
          ,"A",PSGX,1,TXTLN) Q
         .. S ^PS(55,DFN,5,+PSGORD,9,PSGXDA,1,TXTLN,0)=^PS(53.1,+PSGORDP,"A",PSG
          X,1,TXTLN,0)
         Q

*****   INDEX OF PSGOEV   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
   %X           DDEDIT+7*,DDEDIT+8!
   %Y           DDEDIT+7*,DDEDIT+8!
   CHK          ENSF+5*,ENSF+6,ENSF+9*,ENSF+10,VFY+22,VFY+23,VFY+25*,VFY+26
                VFY+27*,DONE+1,DONE+2,DONE+6!,CHK+5*,CHK+6*,CHK+7*,CHK+8*
                CHK+10*,CHK+11*,CHK+12*,CHK+14*,CHK+16,CHK+17*,CHK+18,CHKM+1
                CHKM+4,CHKM+5,CHKM+6,CHKM+7*,DDCHK+1*,DDCHK+3*,DDCHK+4
                DDEDIT+7,AESCREEN+3
   DA           VFY+33*,VFY+35!*,VFY+39*,VFY+44*,VFY+55*,DONE+6!,AESCREEN+4
   DA(1         VFY+35*,VFY+44*,AESCREEN+4
   DFN          VFY+8,VFY+31,VFY+32,VFY+35,VFY+36,VFY+40,VFY+41,VFY+42,ACTLOG~
                ACTLOG+6,ACTLOG+7,ACTLOG+9,ACTLOG+10
   DIE          VFY+33*,VFY+35!*,VFY+39*,DONE+6!
   DIR          VFY+62!,DONE+3~,CHKM+7~,CONT+1~,CONT+2!
   DIR("A"      DONE+3*,CONT+3*
   DIR("B"      DONE+3*,CONT+3*
   DIR(0        VFY+62*,DONE+3*,CHKM+7*,CONT+3*
   DIRUT        CONT+1~,CONT+2!
   DP           DONE+6!
   DR           VFY+33*,VFY+35!*,VFY+39*,DONE+6!
   DRG          CHK~,CHK+5,CHK+12,CHK+14,CHK+15,DDEDIT+8!
   DRGF         DDCHK+1*,DDCHK+2,DDCHK+3,DDEDIT+2,DDEDIT+4,DDEDIT+7*,DDEDIT+8!
   DT           ALLERGY+5
   DTOUT        CHKM+7~
   DUOUT        CHKM+7~
   DUR          VFY+47~,VFY+48*,VFY+49
   DURON        VFY+47~*,VFY+48
   DUZ          VFY+55,VFY+56
   F            DONE+6!
   FILE55       VFY+31~*,VFY+35
   FILE55N0     VFY+31~*,VFY+32
   LIST         VFY+2~*,VFY+8,VFY+9,VFY+11,VFY+15
   ND           DONE+6!,CHK~,CHK+7,CHK+8,CHK+11
   ND2          CHK~,CHK+10,CHK+11
   OEORD        VFY+31~,VFY+32*,VFY+34,VFY+35
   OOEORD       VFY+31~,VFY+32*
   PND0         VFY+30~*,VFY+31,VFY+32
>> PSGACT       ENSF+11*,ENSF+12*,VFY+63*
   PSGAL        DONE+6!
   PSGAL("C"    VFY+44*
   PSGAL531     ACTLOG+3~,ACTLOG+5*,ACTLOG+7
   PSGALFN      VFY+51!
>> PSGAT        VFY+25
>> PSGCANFL     VFY+63*
>> PSGCOPY      VFY+14
   PSGDDI       ALLERGY+1~,ALLERGY+3*,ALLERGY+4
   PSGDFLG      CHK+13!,CHK+14*
>> PSGDI        CHK+13*,CHK+14*
   PSGDN        VFY+2~*,VFY+6*,VFY+7
>> PSGDT        VFY+55,VFY+56
   PSGODA       DONE+6!
>> PSGODDD(1    VFY+52
>> PSGOEAV      ENSF+2*,ENSF+3
>> PSGOEEF(109  VFY+19*
   PSGOES       ENSF+3,ENSF+9~*,VFY+27~*,CHK+17~*
>> PSGONF       VFY+52
   PSGORD       EN~,ENSF+3,ENSF+5*,ENSF+7,ENSF+11,ENSF+12,VFY+1,VFY+4,VFY+8
                VFY+11,VFY+15,VFY+29,VFY+30,VFY+32,VFY+33,VFY+34,VFY+37,VFY+38
                VFY+39,VFY+40,VFY+41,VFY+42,VFY+44,VFY+45,VFY+46,VFY+47,VFY+49
                VFY+50,VFY+53,VFY+55,VFY+56,VFY+57,VFY+58,VFY+59
                VFY+60,VFY+63,VFY+64,VFY+65,VFY+67,VFY+74,ALLERGY~,ALLERGY+2
                ALLERGY+3,ALLERGY+4,DDCHK+1,ACTLOG~,ACTLOG+6,ACTLOG+7,ACTLOG+9
                ACTLOG+10
   PSGORDP      VFY+33*,VFY+37*,VFY+43,VFY+50,ACTLOG~,ACTLOG+4,ACTLOG+5
                ACTLOG+8,ACTLOG+9,ACTLOG+10
   PSGORDR      VFY+30~*,VFY+31,VFY+32,VFY+34,VFY+35,VFY+36
   PSGORQF      VFY+2~,VFY+15,VFY+16
>> PSGP         ENSF+5,ENSF+11,ENSF+12,VFY+15,VFY+36,VFY+44,VFY+45,VFY+46
                VFY+48,VFY+49,VFY+50,VFY+55,VFY+56,VFY+57,VFY+58,VFY+59,VFY+60
                VFY+63,VFY+64,VFY+74,DONE+5,DDCHK+1
   PSGPD        DDCHK+2*,DDCHK+3,DDEDIT+6,DDEDIT+8!
   PSGPFLG      CHK+13!,CHK+15*
>> PSGRDTX      VFY+43*,VFY+45,VFY+46,VFY+48
   PSGRFD       VFY+51!
   PSGRSD       VFY+51!
   PSGS0XT      ENSF+9~,VFY+24*,VFY+25,VFY+27~,CHK+17~
   PSGS0Y       ENSF+9~,VFY+27~,CHK+17~
>> PSGSCH       ENSF+8,ENSF+9,VFY+23,VFY+24,VFY+26,VFY+27,CHK+16,CHK+17
>> PSGST        VFY+23
   PSGTOL       VFY+55*,DONE+6!
   PSGTOO       VFY+55*,DONE+6!
   PSGUOW       VFY+55*,DONE+6!
   PSGX         ACTLOG+3~,ACTLOG+4*,ACTLOG+5,ACTLOG+8,ACTLOG+9,ACTLOG+10
   PSGXDA       ACTLOG+3~,ACTLOG+6*,ACTLOG+7,ACTLOG+9,ACTLOG+10
>> PSJACEPT     ENSF+10,VFY+18,VFY+20*
   PSJAGYSV     VFY+67!
   PSJALLGY     VFY+15,ALLERGY~
   PSJALLGY(    ALLERGY+7*
   PSJCNT       VFY+2~*,VFY+5*,VFY+6
   PSJCNT1      VFY+2~*,VFY+9*,VFY+10,VFY+11
   PSJCNT2      VFY+2~*,VFY+10*,VFY+11
>> PSJCOM       VFY+1*
   PSJDD        ALLERGY+1~,ALLERGY+4*,ALLERGY+5,ALLERGY+7
   PSJDIS       VFY+2~*,VFY+9,VFY+11*,VFY+14,VFY+15
   PSJDOSE      VFY+2~,DONE+6!
   PSJDOSE("WARN" 
                VFY+18
   PSJDOSE("WARN1" 
                VFY+18
   PSJDSFLG     VFY+2~,VFY+18
>> PSJDSVFY     VFY+15
   PSJFLG       VFY+2~*,VFY+4*,VFY+5,VFY+6
>> PSJHLDFN     VFY+40,VFY+41
>> PSJLMFIN     VFY+14
>> PSJNEWOE     VFY+14
>> PSJORD       VFY+15,VFY+65
>> PSJPRI       DONE+2
   PSJPRIO      VFY+30~,VFY+40*,VFY+42
   PSJSCHED     VFY+30~,VFY+41*,VFY+42
>> PSJSPEED     ENSF+10,VFY+14,VFY+61,VFY+62,DONE+2
>> PSJSTARI     VFY+14,VFY+15
>> PSJSYSL      VFY+55
>> PSJSYSP      CHK+12,CHK+14,DDEDIT+4,DDEDIT+5,DDEDIT+7
>> PSJSYSP0     ENSF+2
>> PSJSYSU      ENSF+2,ENSF+4,ENSF+6,ENSF+11,ENSF+12,VFY+44,VFY+53,VFY+54
                VFY+56,VFY+63,VFY+64,VFY+74,DONE+2
   PSJVAR       DONE+6!
   PSJX         ALLERGY+1~,ALLERGY+5*,ALLERGY+6
   Q            DDEDIT+4*,ACTLOG+3~,ACTLOG+6*
   QQ           ACTLOG+3~,ACTLOG+6*
   QX           VFY+24~
   SDW          VFY+24~
   SWD          VFY+24~
>> TIUDA        DONE+5
   TXTLN        ACTLOG+8~*,ACTLOG+9,ACTLOG+10
   U            VFY+6,VFY+7,VFY+11,VFY+30,VFY+31,VFY+32,VFY+35,VFY+46,VFY+48
                VFY+54,VFY+55,VFY+57,VFY+58,VFY+59,VFY+60,ALLERGY+5,CHK+12
                AESCREEN+4,ACTLOG+6
>> VALMBCK      VFY+64*,DONE+6*
   VND4         VFY+44*,VFY+53,VFY+54*,VFY+56*,VFY+57,VFY+58,VFY+59,VFY+60
                DONE+6!
   X            ENSF+5*,ENSF+9~*,VFY+24~*,VFY+27~*,VFY+52~*,VFY+53,DONE+6!
                CHK+17~*,CHKM+4*,DDEDIT+4*,DDEDIT+5,DDEDIT+6
   XABB         VFY+24~
   Y            ENSF+9~,VFY+27~,DONE+4,CHK+4*,CHK+17~,CHKM+1!,CONT+1~,CONT+5
                DDEDIT+4*,AESCREEN+4*,AESCREEN+5
   ZZND         DONE+6!

Global Variables  ( * Changed  ! Killed)
   ^ORD(101            AESCREEN+4
   ^PS(50.7            CHK+5
   ^PS(53.1            ENSF+3,ENSF+5,ENSF+7,VFY+1,VFY+5,VFY+6,VFY+30,VFY+40
                       VFY+41,VFY+43,ALLERGY+3,ALLERGY+4,ACTLOG+4,ACTLOG+5
                       ACTLOG+8,ACTLOG+9,ACTLOG+10
   ^PS(53.45           DDEDIT+4!*,DDEDIT+5*
   ^PS(55              ENSF+5,ENSF+11,ENSF+12,VFY+40,VFY+41,VFY+44,VFY+49*
                       VFY+55*,VFY+56*,VFY+57*,VFY+58*,VFY+59!,VFY+60!,VFY+63*
                       ACTLOG+6,ACTLOG+7*,ACTLOG+9*,ACTLOG+10*
   ^PSDRUG(            VFY+7,ALLERGY+5
   ^TMP("PSODAOC"      VFY+65*
   ^TMP($J             VFY+9,VFY+11,VFY+15!

Naked Globals
   ^(           ENSF+7,DDEDIT+4,ACTLOG+6
   ^("I"        ALLERGY+5
   ^(0          ENSF+5,CHK+10,ACTLOG+6*
   ^(2          ENSF+7,ALLERGY+5
   ^(4          ENSF+11,VFY+63
   ^(7          VFY+55*

Cache Objects
   NONE

Marked Items
   NONE

Label References
   $$CONT       VFY+18
   ACTLOG       VFY+50
   ALLERGY      VFY+15
   CHK          ENSF+7
   DDCHK        ENSF+6,VFY+22
   DONE         ENSF+5,ENSF+6,ENSF+10,ENSF+11,ENSF+12,VFY+22,VFY+23,VFY+26
   VFY          ENSF+11

External References
   %XY^%RCR            DDEDIT+7
   ^DIE                VFY+33,VFY+35,VFY+39
   ^DIR                VFY+62,DONE+3,CHKM+7,CONT+4
   ^PSGAL5             VFY+44
   NEWUDAL^PSGAL5      VFY+45,VFY+46
   $$DDOK^PSGOE2       CHK+14,DDCHK+3
   $$OIOK^PSGOE2       CHK+15
   $$CHECK^PSGOE8      CHK+12
   ENDRG^PSGOEF1       DDEDIT+6
   EXPOE^PSGOER        VFY+32
   ORSET^PSGOETO1      ENSF+3
   ^PSGOT              VFY+39
   START^PSGOTR        VFY+34
   EN^PSGPEN           VFY+36,VFY+53
   DW^PSGS0            VFY+24
   ENOS^PSGS0          ENSF+9,VFY+27,CHK+17
   ENDDC^PSGSICHK      VFY+15
   ENL^PSGVDS          VFY+55
   NEWJ^PSJADM         VFY+70
   PROFILE^PSJBLDOC    VFY+8
   VFY^PSJCOM          VFY+1
   DOSECHK^PSJDOSE     VFY+3
   SETVAR^PSJDOSE      VFY+18
   EN1^PSJHL2          VFY+36,VFY+64,VFY+74
   NOTIFY^PSJHL4       VFY+42
   $$GETDUR^PSJLIVMD   VFY+48
   REQDT^PSJLIVMD      VFY+38
   $$LASTREN^PSJLMPRI  VFY+32
   SETOC^PSJNEWOC      VFY+67
   IN^PSJOCDS          VFY+15
   CLOZSND^PSJOE       VFY+70
   UNL^PSSLOCK         VFY+36
   MAIN^TIUEDIT        DONE+5
   EN^VALM             ENSF+10,VFY+15
   FULL^VALM1          ENSF+4,VFY+17,CHKM+1
   PAUSE^VALM1         VFY+18,VFY+25

*****   END   *****

   Press return to continue:

PSJCLOLS * *  35 Lines,  2642 Bytes, Checksum: B11327318
                                                  Jun 01, 2016@09:50:20 page 12
              204 bytes in comments
PSJCLOLS ;ALB/RTW - LIST INPATIENT CLOZAPINE ORDERS ENTERED BY OVERRIDE ; 03/25/
          2016 10:31
         ;;5.0;INPATIENT PHARMACY;**327**;;DEC 1997
         ;RTW copied from routine PSOCLOLS and modified for the NCC Clozapine in
          patient pharmacy project
         W !,"Print list of clozapine prescriptions overriding lockout",!
DATE     S %DT="EAX",%DT("A")="Beginning date : " D ^%DT G EXIT:Y<0 S PSOBD=Y
         S %DT("A")="Ending date : " D ^%DT G EXIT:Y<0 S PSOED=Y+.3 I PSOED<PSOB
          D W !!,"Ending date must be after beginning date" G DATE
DEV      S %ZIS("B")="",%ZIS="MQ" D ^%ZIS G EXIT:POP I $E(IOST)'="P" W !,"Select
           a printer " G DEV
         I $D(IO("Q")) G QUE
DQ       ;Entry to report
         W:$Y @IOF D HD I '$O(^PS(53.8,"B",PSOBD)) W !,?5,"NO PRESCRIPTIONS FOUN
          D",@IOF G EXIT
         I $O(^PS(53.8,"B",PSOBD))>PSOED W !,?5,"NO PRESCRIPTIONS FOUND",@IOF G 
          EXIT
         F PSJOD=PSOBD-.1:0 S PSJOD=$O(^PS(53.8,"B",PSJOD)) Q:'PSJOD  Q:PSJOD>PS
          OED  S PSOI=+$O(^(PSJOD,0)) I $D(^PS(53.8,PSOI,0)) S PSJDATA=^(0) D PR
          INT
         W @IOF
EXIT     D ^%ZISC K %DT,PSJDRG,POP,PSJOD,PSOI,PSJDATA,PSJRX,PSJUSR,PSJAPR,PSJREA
          ,PSJCOM,PSJPAT,PSOBD,PSOED,X,J,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK Q
         ;
PRINT    I $Y+9>IOSL W @IOF D HD
         Q:$P(PSJDATA,"^",2)=""!($P(PSJDATA,"^",3)="")!($P(PSJDATA,"^",4)="")!($
          P(PSJDATA,"^",5)="")
         S PSJORD=+$P(PSJDATA,"^",2),PSJUSR=$P(PSJDATA,"^",3),PSJAPR=$P(PSJDATA,
          "^",4),PSJREA=$P(PSJDATA,"^",5),PSJUSR=$P(^VA(200,PSJUSR,0),"^"),PSJAP
          R=$P(^VA(200,PSJAPR,0),"^"),PSJCOM=$P(PSJDATA,"^",6)
         S PSJNUM=0 F  S PSJNUM=$O(^OR(100,PSJORD,4.5,PSJNUM)) Q:'PSJNUM  D
         . I $P(^OR(100,PSJORD,4.5,PSJNUM,0),"^",4)["DRUG" D
         . . S PSJDRG=$P($G(^OR(100,PSJORD,4.5,PSJNUM,1)),"^",1)
         Q:'$D(PSJDRG)
         S PSJORD=$S($D(^OR(100,PSJORD,0)):^(0),1:""),PSJPAT=+$P(PSJORD,"^",2)
         I PSJORD]"" S PSJPAT=$P(^DPT(PSJPAT,0),"^"),PSJDRG=$P(^PSDRUG(PSJDRG,0)
          ,"^")
         W !,?3,"Date : ",$E(PSJOD,4,5),"/",$E(PSJOD,6,7),"/",$E(PSJOD,2,3),?25,
          "ORDER # : ",$S(PSJORD]"":$P(PSJORD,"^"),1:"UNKNOWN"),?45,"Patient : "
          ,$S(PSJORD]"":PSJPAT,1:"UNKNOWN")
         W !,?3,"DRUG : ",$S(PSJORD]"":PSJDRG,1:"UNKNOWN (PRESCRIPTION DELETED)"
          )
         W !,?3,"Entered by : ",PSJUSR,!,?3,"Approved by : ",PSJAPR
         W !,?3,"Lockout Reason : ",$P(^PS(52.54,PSJREA,0),"^")
         W !,?3,"Comments : " I $L(PSJCOM)<65 W PSJCOM,!! Q
         F J=1:1 Q:$P(PSJCOM," ",J,9999)=""  S X=$P(PSJCOM," ",J) W:$L(X)+$X>70 
          !,?14 W X," "
         W !! Q
HD       U IO W !!,?5,"LIST OF ORDERS WRITTEN FOR CLOZAPINE OVERRIDING LOCKOUT",
          !,?10,"FOR THE DATE RANGE ",$E(PSOBD,4,5),"/",$E(PSOBD,6,7),"/",$E(PSO
          BD,2,3)," THROUGH ",$E(PSOED,4,5),"/",$E(PSOED,6,7),"/",$E(PSOED,2,3),
          ! Q
         ;
QUE      ;queue job
         S ZTRTN="DQ^PSJCLOLS",ZTDESC="CLOZAPINE LIST",ZTSAVE("PSOBD")="",ZTSAVE
          ("PSOED")="" D ^%ZTLOAD G EXIT

*****   INDEX OF PSJCLOLS   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
   %DT          DATE*,EXIT!
   %DT("A"      DATE*,DATE+1*
>> %ZIS         DEV*
>> %ZIS("B"     DEV*
   IO           HD
   IO("Q"       DEV+1
   IOF          DQ+1,DQ+2,DQ+4,PRINT
   IOSL         PRINT
   IOST         DEV
   J            EXIT!,PRINT+14*
   POP          DEV,EXIT!
   PSJAPR       EXIT!,PRINT+2*,PRINT+11
   PSJCOM       EXIT!,PRINT+2*,PRINT+13,PRINT+14
   PSJDATA      DQ+3*,EXIT!,PRINT+1,PRINT+2
   PSJDRG       EXIT!,PRINT+5*,PRINT+6,PRINT+8*,PRINT+10
>> PSJNUM       PRINT+3*,PRINT+4,PRINT+5
   PSJOD        DQ+3*,EXIT!,PRINT+9
>> PSJORD       PRINT+2*,PRINT+3,PRINT+4,PRINT+5,PRINT+7*,PRINT+8,PRINT+9
                PRINT+10
   PSJPAT       EXIT!,PRINT+7*,PRINT+8*,PRINT+9
   PSJREA       EXIT!,PRINT+2*,PRINT+12
   PSJRX        EXIT!
   PSJUSR       EXIT!,PRINT+2*,PRINT+11
   PSOBD        DATE*,DATE+1,DQ+1,DQ+2,DQ+3,EXIT!,HD
   PSOED        DATE+1*,DQ+2,DQ+3,EXIT!,HD
   PSOI         DQ+3*,EXIT!
   X            EXIT!,PRINT+14*
>> Y            DATE,DATE+1
   ZTDESC       EXIT!,QUE+1*
   ZTIO         EXIT!
   ZTRTN        EXIT!,QUE+1*
   ZTSAVE       EXIT!
   ZTSAVE("PSOBD" 
                QUE+1*
   ZTSAVE("PSOED" 
                QUE+1*
   ZTSK         EXIT!

Global Variables  ( * Changed  ! Killed)
   ^DPT(               PRINT+8
   ^OR(100             PRINT+3,PRINT+4,PRINT+5,PRINT+7
   ^PS(52.54           PRINT+12
   ^PS(53.8            DQ+1,DQ+2,DQ+3
   ^PSDRUG(            PRINT+8
   ^VA(200             PRINT+2

Naked Globals
   ^(           DQ+3
   ^(0          DQ+3,PRINT+7

Cache Objects
   NONE

Marked Items
   NONE

Label References
   DATE         DATE+1
   DEV          DEV
   EXIT         DATE,DATE+1,DEV,DQ+1,DQ+2,QUE+1
   HD           DQ+1,PRINT
   PRINT        DQ+3
   QUE          DEV+1

External References
   ^%DT                DATE,DATE+1
   ^%ZIS               DEV
   ^%ZISC              EXIT
   ^%ZTLOAD            QUE+1

*****   END   *****

   Press return to continue:

PSJCLOZ  * *  83 Lines,  3183 Bytes, Checksum: B15561166
                                                  Jun 01, 2016@09:50:20 page 13
              245 bytes in comments
PSJCLOZ  ; DAL/RJS - INPATIENT CLOZAPINE ORDER CHECK ; 1/8/16 6:50pm
         ;;5.0;INPATIENT MEDICATIONS ;**327**;01 DEC 15;
         ;
CLOZ(DFN,DRUG) --
          ;
         ; DFN MUST BE SET TO PATIENT IEN
         ; DRUG MUST BE SET TO DRUG IEN
         I '$G(DFN)!('$G(DRUG)) S ANQX=0 Q
         D PROVCHK($G(PSGPR)) Q:ANQX
         N RTN
         S RTN=$P($G(^PSDRUG(DRUG,"CLOZ1")),U)
         D:$L(RTN) ^@RTN
         Q
         ;
PROVCHK(PROV) --
          ;
         N PSJQUIT
         ;
         S (ANQX,PSJQUIT)=0
         I $G(PROV) D
         .I '$L($$DEA^XUSER(,PROV)) D
         ..S (ANQX,PSJQUIT)=1
          ..W !," ",!,?5,"*** Provider must have a DEA# or VA# to write prescrip
          tions for this drug."
         .Q:PSJQUIT
         .I '$D(^XUSEC("YSCL AUTHORIZED",PROV)) D
         ..S (ANQX,PSJQUIT)=1
         ..W !," ",!,?5,"*** Provider must hold YSCL AUTHORIZED key to write pre
          scriptions for clozapine."
         Q
BEFQUIT  ;
         Q:'$G(QOAA)
         N QODS,QORF,ORMAX,ORCLPAT
         S QODS=$O(^ORD(101.41,"AB","OR GTX DAYS SUPPLY","")) Q:QODS'>0
         S QODS=$O(^ORD(101.41,ORX,6,"D",QODS,"")) Q:QOIEN'>0
         S QODS=$G(^ORD(101.41,ORX,6,QODS,1))
         S QORF=$O(^ORD(101.41,"AB","OR GTX REFILLS","")) Q:QORF'>0
         S QORF=$O(^ORD(101.41,ORX,6,"D",QORF,"")) Q:QOIEN'>0
         S QORF=$G(^ORD(101.41,ORX,6,QORF,1))
         S QORF=QORF+1
         S ORCLPAT=$P(ORYS,U,7)
         S ORMAX=$S(ORYS="M":28,ORYS="B":14,ORYS="W":7,1:90)
         I QORF*QODS>ORMAX D
         .K ORY
         .S ORY=1_U_ORCLOZ
         .W !,?5,"Problem Ordering Clozapine Related Medication"_U_ORCLOZ
         .W !,?5,"*** This patient is only allowed an order with a maximum Days 
          Supply of "_ORMAX_"."
         .W !,?5,"This includes the amounts added by any refills entered in with
           the order also."
         Q
OVERRIDE ;
         I '$G(^XUSEC("PSOLOCKCLOZ",PROV)) D  Q 1
         .N Y
         .W !," ",!,?5,"*** You are not authorized to override Clozapine orders.
          ",!," "
         .K DIR S DIR(0)="E",DIR("A")="Press Return to Continue..." D ^DIR K DIR
           W @IOF
         Q
PSJFILE(DFN) --
          ;
         S PSJCLPAT=DFN
         I $D(ANQDATA) S PSJPROV=$P(ANQDATA,"^",5),PSJ1PH=$P(ANQDATA,"^"),PSJ2PH
          =$P(ANQDATA,"^",2),PSJREASN=$P(ANQDATA,"^",3),PSJREMRK=$P(ANQDATA,"^",
          4) D NOW^%DTC G:$D(^PS(53,8,"B",%)) PSJFILE D
         . I $D(ORO) S PSJPROV=$P(ORO,"^",4),PSJORN=$P(ORO,"^",1),PSJORDER("PSJO
          RN")=PSJORN
         . K DD,DO S DIC="^PS(53.8,",DIC(0)="L",DLAYGO=53.8,X=%
         . D FILE^DICN K DIC,DLAYGO,DD,DO,DA,DR
         . N PS538 S (PS538,DA)=+Y,DIE="^PS(53.8,",DR="1////"_PSJORDER("PSJORN")
          _";3////"_PSJPROV_";2////"_PSJ1PH_";4////"_PSJREASN_";5////"_PSJREMRK_
          ";6////"_PSJ2PH
         . D ^DIE K DIE,DA,DR
         . K ANQDATA,X,Y,%,ANQREM
         . W !,"THE OVERRIDEN ORDER IS COMPLETE",!
         . D ALERT
         Q
ALERT    ; send an alert to the three approving team members
         S XQADATA=PSCLPAT ;
         S PSOLAST4=$E($P($G(^DPT(PSCLPAT,0)),"^",9),6,9)
         S XQAARCH=1
         S XQAFLG="D"
         S XQA(PSJ1PH)="",XQA(PSJ2PH)="",XQA(PSJPROV)=""
         D NOW^%DTC S Y=% D DD^%DT S PSCDATE=Y
         S XQAMSG=$$GET1^DIQ(2,PSCLPAT,.01)_" ("_PSOLAST4_")"_": CLOZAPINE OVERR
          IDE RX PROCESSED  :"_PSCDATE
         S XQAID="PSI"_","_PSCLPAT
         D PHGRP^PSOCLO1 M XQA=XMY D SETUP^XQALERT
         W !!,"OVERRIDE ALERTS HAVE BEEN SENT TO THE APPROVING TEAM MEMBERS",!!
         Q
         ;
READ     ;
         ;W !,"Do you concurr with the requested override for "_CLOZPAT
         S DIR("A")="Do you concurr with the requested override for "_CLOZPAT,DI
          R(0)="Y",DIR("B")="N" D ^DIR G END:$D(DIRUT) K DIR D:'Y!($D(DIRUT)) EN
          D
         Q
END      ;
         K DIRUT,DIROUT,DIR
         Q 

*****   INDEX OF PSJCLOZ   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
   %            PSJFILE+2,PSJFILE+4,PSJFILE+8!,ALERT+6
   ANQDATA      PSJFILE+2,PSJFILE+8!
   ANQREM       PSJFILE+8!
>> ANQX         CLOZ+3*,CLOZ+4,PROVCHK+3*,PROVCHK+6*,PROVCHK+10*
>> CLOZPAT      READ+2
   DA           PSJFILE+5!,PSJFILE+6*,PSJFILE+7!
   DD           PSJFILE+4!,PSJFILE+5!
   DFN          CLOZ~,CLOZ+3,PSJFILE~,PSJFILE+1
   DIC          PSJFILE+4*,PSJFILE+5!
   DIC(0        PSJFILE+4*
   DIE          PSJFILE+6*,PSJFILE+7!
   DIR          OVERRIDE+4!,READ+2!,END+1!
   DIR("A"      OVERRIDE+4*,READ+2*
   DIR("B"      READ+2*
   DIR(0        OVERRIDE+4*,READ+2*
   DIROUT       END+1!
   DIRUT        READ+2,END+1!
   DLAYGO       PSJFILE+4*,PSJFILE+5!
   DO           PSJFILE+4!,PSJFILE+5!
   DR           PSJFILE+5!,PSJFILE+6*,PSJFILE+7!
   DRUG         CLOZ~,CLOZ+3,CLOZ+6
   IOF          OVERRIDE+4
>> ORCLOZ       BEFQUIT+14,BEFQUIT+15
   ORCLPAT      BEFQUIT+2~,BEFQUIT+10*
   ORMAX        BEFQUIT+2~,BEFQUIT+11*,BEFQUIT+12,BEFQUIT+16
>> ORO          PSJFILE+3
>> ORX          BEFQUIT+4,BEFQUIT+5,BEFQUIT+7,BEFQUIT+8
   ORY          BEFQUIT+13!,BEFQUIT+14*
>> ORYS         BEFQUIT+10,BEFQUIT+11
   PROV         PROVCHK~,PROVCHK+4,PROVCHK+5,PROVCHK+9,OVERRIDE+1
   PS538        PSJFILE+6~*
>> PSCDATE      ALERT+6*,ALERT+7
>> PSCLPAT      ALERT+1,ALERT+2,ALERT+7,ALERT+8
>> PSGPR        CLOZ+4
>> PSJ1PH       PSJFILE+2*,PSJFILE+6,ALERT+5
>> PSJ2PH       PSJFILE+2*,PSJFILE+6,ALERT+5
>> PSJCLPAT     PSJFILE+1*
>> PSJORDER("PSJORN" 
                PSJFILE+3*,PSJFILE+6
>> PSJORN       PSJFILE+3*
>> PSJPROV      PSJFILE+2*,PSJFILE+3*,PSJFILE+6,ALERT+5
   PSJQUIT      PROVCHK+1~,PROVCHK+3*,PROVCHK+6*,PROVCHK+8,PROVCHK+10*
>> PSJREASN     PSJFILE+2*,PSJFILE+6
>> PSJREMRK     PSJFILE+2*,PSJFILE+6
>> PSOLAST4     ALERT+2*,ALERT+7
>> QOAA         BEFQUIT+1
   QODS         BEFQUIT+2~,BEFQUIT+3*,BEFQUIT+4*,BEFQUIT+5*,BEFQUIT+12
>> QOIEN        BEFQUIT+4,BEFQUIT+7
   QORF         BEFQUIT+2~,BEFQUIT+6*,BEFQUIT+7*,BEFQUIT+8*,BEFQUIT+9*
                BEFQUIT+12
   RTN          CLOZ+5~,CLOZ+6*,CLOZ+7
   U            CLOZ+6,BEFQUIT+10,BEFQUIT+14,BEFQUIT+15
   X            PSJFILE+4*,PSJFILE+8!
>> XMY          ALERT+9
>> XQA          ALERT+9*
>> XQA(         ALERT+5*
>> XQAARCH      ALERT+3*
>> XQADATA      ALERT+1*
>> XQAFLG       ALERT+4*
>> XQAID        ALERT+8*
>> XQAMSG       ALERT+7*
   Y            OVERRIDE+2~,PSJFILE+6,PSJFILE+8!,ALERT+6*,READ+2

Global Variables  ( * Changed  ! Killed)
   ^DPT(               ALERT+2
   ^ORD(101.41         BEFQUIT+3,BEFQUIT+4,BEFQUIT+5,BEFQUIT+6,BEFQUIT+7
                       BEFQUIT+8
   ^PS(53              PSJFILE+2
   ^PSDRUG(            CLOZ+6
   ^XUSEC("PSOLOCKCLOZ"OVERRIDE+1
   ^XUSEC("YSCL AUTHORIZED"
                       PROVCHK+9

Naked Globals
   NONE

Cache Objects
   NONE

Marked Items
   NONE

Label References
   ALERT        PSJFILE+10
   END          READ+2
   PROVCHK      CLOZ+4
   PSJFILE      PSJFILE+2

External References
   DD^%DT              ALERT+6
   NOW^%DTC            PSJFILE+2,ALERT+6
   ^@(                 CLOZ+7
   FILE^DICN           PSJFILE+5
   ^DIE                PSJFILE+7
   $$GET1^DIQ          ALERT+7
   ^DIR                OVERRIDE+4,READ+2
   PHGRP^PSOCLO1       ALERT+9
   SETUP^XQALERT       ALERT+9
   $$DEA^XUSER         PROVCHK+5

*****   END   *****

   Press return to continue:

PSJOE    * *  248 Lines,  12494 Bytes, Checksum: B114989154
                                                  Jun 01, 2016@09:50:20 page 14
              1712 bytes in comments
PSJOE    ;BIR/MLM - INPATIENT ORDER ENTRY ;23 Jun 98  1:46 PM
         ;;5.0;INPATIENT MEDICATIONS;**7,26,29,33,42,50,56,72,58,85,95,80,110,11
          1,133,140,151,149,181,252,281,327**;16 DEC 97;Build 113
         ;
         ; Reference to ^PS(55 is supported by DBIA #2191.
         ; Reference to EN^VALM is supported by DBIA #10118.
         ; Reference to FULL^VALM1 is supported by DBIA #10116.
         ; Reference to PAUSE^VALM1 is supported by DBIA #10116.
         ; Reference to ^PSSLOCK is supported by DBIA #2789
         ; Reference to ^DPT( is supported by DBIA #10035.
         ; Reference to ^ORCFLAG is supported by DBIA #3620.
         ; Reference to ^SDAMA203 is supported by DBIA #4133.
         ; Reference to ^TMP("PSODAOC" is supported by DBIA #6071.
         ;
EN       ; Start Inpatient LM OE
         N PSJLK,PSJNEWOE,PSJLMCON,PSJPROT,XQORS,VALMEVL D ENCV^PSGSETU,^PSIVXU
         I $D(XQUIT) K XQUIT G DONE
         K PSGVBY,PSJPR S (PSJOL,PSJACOK,PSGOP,PSGNEF,PSGOEAV,PSGPXN)="" L +^PS(
          53.45,PSJSYSP):1 E  D LOCKERR^PSJOE G DONE^PSJOE
         F  S (PSJLMCON,PSGPTMP)=0 D ^PSJP,HK Q:PSGP'>0  S PSJPROT=3,DFN=PSGP D 
          ^PSJAC D  I PSJLK D UL^PSSLOCK(PSGP)
         .K ^TMP("PSJ",$J)
         .S PSJLK=$$L^PSSLOCK(PSGP,1) I 'PSJLK W !,$C(7),$P(PSJLK,U,2) Q
         .K PSJLMPRO D EN^VALM("PSJ LM BRIEF PATIENT INFO")
         .N NXTPT S NXTPT=0 F  Q:$G(NXTPT)  D
         ..K PSGRDTX
         ..I $G(PSJLMCON)!$G(PSJNEWOE) D
         ...S PSJOL=$S(",S,L,"[(","_$G(PSJOL)_","):PSJOL,1:"S")
         ...S PSJLMPRO=1,PSJLMCON=1,PSJNEWOE=0 D EN^VALM("PSJ LM OE")
         ..I $G(PSJNEWOE)!($G(VALMBCK)="Q") S PSJNEWOE=0 Q
         ..I $G(PSJLMCON)&$G(PSJLMPRO)&'$D(^TMP("PSJ",$J)) D  Q
         ...S PSJLMCON=0,PSJLMPRO=0 D EN^VALM("PSJ LM BRIEF PATIENT INFO")
         ...I $G(PSJNEWOE) S NXTPT=0 Q
         ...S NXTPT=1
         ..S NXTPT=1,PSJNEWOE=0
         .S PSJOL="S"
         .I $G(PSGPXN) I $P(PSJSYSW0,U,29)]""!($G(PSJCOM)) S PSGPXPT=PSGP D  K P
          SGPXPT S PSGPXN=0
         ..N DFN,PSGP,PSJPXDP
         ..I $P(PSJSYSW0,U,29)="" S PSJPDXP=1 D
         ...;N IO,ION,IOS D HOME^%ZIS S $P(PSJSYSW0,U,29)=+$G(IOS)
         ...D HOME^%ZIS S $P(PSJSYSW0,U,29)=+$G(IOS)
         ..S (PSGP,DFN)=PSGPXPT D ^PSGPER S:$G(PSJPDXP) $P(PSJSYSW0,U,29)="" K P
          SJPDXP
         .D ENCV^PSGSETU,^PSIVXU
         K PSJLMPRO,^TMP("PSJPRO",$J),^TMP("PSJ",$J),^TMP("PSJON",$J)
DONE     ;
         ; -- RTC 198753 - correct typo - r PSJALGSV w PSJAGYSV
         K PSJAGYSV,PSJEXCPT,PSJOCER,^TMP($J,"PSJPRE"),^TMP("PSODAOC",$J),^TMP("
          PSJDAOC",$J)
         K AC,ACTION,D1,D2,MI,N,ON,P3,PNOW,PSIVAT,PSIVLN,PSIVSTR L -^PS(53.45,PS
          JSYSP)
         K DA,DRG,NE,PSGCF,PSGCANFL,PSGNEDFD,PSGNEF,PSGNEFD,PSGNEPR,PSGNESD,PSJA
          COK,PSJOE,PSJOECNT,PSJOEPF,PSJORD,PSGOEA,PSGOEAV,PSGOL,PSGOS,PSGON,PSG
          OP,PSGORD,PSGS0XT,PSGS0Y,RCT,ST,WD,XREF,Z,PSJIVORF,PSJIVPCL
         K PSGOEORF,PSIVREA,PSJOPC,PSJORL,PSJORPCL,PSJORTOI,RF,WSCHADM,PSJLM,PSJ
          CT
         K DIU,DRGI,FLAG,FQC,ND2,PRI,PSGOE,PSGPRI,PSGSDN,PSGOEDMR,PSGOEPR,PSGPTS
          ,PSGTOL,PSGTOO,PSGUOW,PSJIVOF,PSJOCNT,PSJON,PSJORQF,PSJORTOU,PSJORVP
         K PSIVENO
         G:$G(PSGPXN) ^PSGPER1 D ENIVKV^PSGSETU
         Q
HK       ; Housekeeping (a nice COBOL term)
         I PSGOP,PSGOP'=PSGP D
         .N PSJACPF,PSJACNWP,PSJPWD,PSJSYSL,PSJSYSW,PSJSYSW0,DFN,VAIN,VAERR S DF
          N=PSGOP
         .D INP^VADPT S PSJPWD=+VAIN(4) I PSJPWD S PSJACPF=10 D WP^PSJAC D:$P(PS
          JSYSL,"^",2)]"" ENQL^PSGLW
         Q:PSGP<0
         S (DFN,PSGOP)=PSGP,X=""
         Q
SELECT   ; Select order from list
         ;Variable PSJOCDSC is used in Complex order dosing checks
         N PSGLMT,PSGODDD,PSJLMQT,PSJLMFIN,PSJUDPRF,PSGRDTX,PSJOCDSC,PSJAGYSV K 
          ^TMP("PSJCOM",$J),^TMP("PSJCOM2",$J),PSJSTARI,^TMP("PSODAOC",$J),^TMP(
          "PSJDAOC",$J)
         S PSGONC=1,PSGLMT=^TMP("PSJPRO",$J,0) D ENASR^PSGON
         I "^"[X S VALMQUIT=1 Q
         S PSJLM=1,PSJSEL=0 F  S PSJSEL=$O(PSGODDD(PSJSEL)) Q:'PSJSEL!($G(Y)<0) 
           F PSJSEL1=1:1:$L(PSGODDD(PSJSEL),",")-1 D
         .K PSJOCDSC
         .S PSJORD=$G(^TMP("PSJON",$J,+$P(PSGODDD(PSJSEL),",",PSJSEL1))) D:PSJOR
          D=+PSJORD SELECT^PSJOEA Q:PSJORD=""!($G(Y)<0)  Q:PSJORD=+PSJORD  D
         ..Q:('$$LS^PSSLOCK(PSGP,PSJORD))
         ..Q:PSJORD=+PSJORD
         ..S PSGORD=""
         ..D DISACTIO(PSGP,PSJORD,"") S:PSJORD["V" PSJORD=ON
         ..D UNL^PSSLOCK(PSGP,PSJORD) Q:$G(Y)<0
         S VALMBCK="Q"
         K PSJLM,PSJOCDSC
         Q
DISACTIO(DFN,PSJORD,PSJPNV) --
                ; Display UD order and allow actions.
         ; PSJORD - Order #_location Code (P:53.1,V:55.01,U:55.06)
         ; PSJPNV - Invoked from Pending/NV option; (gets different hidden menu)
         ; PSJDSVFY - Flag if non-vf order was edited
         ; PSJENHOC=1 if DI,DT were display. This will be used by dosing OC to c
          heck if error messages should display or not
         ; PSJAGYSV=1 If UD was edited
         ;N PSGP,PSJIVFLG,PSGSDX,PSGFDX,PSJXX1,ON55,PSJDSVFY,PSJENHOC,PSJAGYSV
         N PSGP,PSJIVFLG,PSGSDX,PSGFDX,PSJXX1,ON55,PSJDSVFY,PSJENHOC,PSIVENO
         D OLDCOM^PSJOE0(DFN,PSJORD)
         S PSGP=DFN D ENIV^PSJAC I PSJORD["V" D EN^PSJLIORD(DFN,PSJORD) Q
         D GETUD^PSJLMGUD(DFN,PSJORD)
         S PSGOEAV=$P(PSJSYSP0,"^",9)&PSJSYSU
         S:$G(PSJTUD) PSGPD=$G(PSJCOI),PSGPDN=$$OINAME^PSJLMUTL(+PSGPD)
         ;; START NCC REMEDIATION >> 327*RJS
         I '$G(PSGDRG) S PSGDRG=$O(^PSDRUG("ASP",PSGPD,0)) I PSGDRG,'$O(^(PSGDRG
          )) Q
         I PSGSTAT'="ACTIVE",PSGSTAT'="NON-VERIFIED"  D
         .S ANQX=0 I $D(^PSDRUG("ACLOZ",PSGDRG)) D CLOZ^PSJCLOZ(PSGP,PSGDRG)
         I $G(ANQX) K DIR S DIR(0)="E" D ^DIR K DIR Q
         ;; END NCC REMEDIATION << 327*RJS
         K PSGOENG I '$D(PSGPRF) D  Q:$G(PSGOENG)
         . I PSJORD["U" L +^PS(55,PSGP,5,+PSJORD):1 E  S PSGOENG=1
         . I PSJORD["P" L +^PS(53.1,+PSJORD):1 E  S PSGOENG=1
         . I $G(PSGOENG) W !,"This order is being edited by another terminal.",!
           S PSGOENG=1 K DIR S DIR(0)="E" D ^DIR K DIR Q
         S PSGACT=$$ENACTION^PSGOE1(PSGP,PSJORD)
         I PSJORD["P" S PSJXX1=$G(^PS(53.1,+PSJORD,0)) I PSGP'=$P(PSJXX1,U,15)!(
          DFN'=$P(PSJXX1,U,15)) L -^PS(53.1,+PSJORD) Q
         I PSJORD["P" D  S PSJXX1=$P($G(^PS(53.1,+PSJORD,0)),U,9) I $S($G(PSJIVF
          LG):1,$G(Y)<0:1,"PADE"[PSJXX1:1,1:0) L -^PS(53.1,+PSJORD) Q
         .I $P(PSJXX1,U,9)="N",($P(PSJXX1,U,4)'="U") D  Q
         .. S P("PON")=PSJORD,PSIVFLG=1
         .. N ON S ON=PSJORD D VF^PSIVORC2
         .I $P(PSJXX1,U,9)="P" D  Q
         ..S:$G(PSJTUD) $P(PSJXX1,U,4)="U"
         ..I $P(PSJXX1,U,4)="U" D  Q:$G(PSJIVFLG)
         ... N VAIP S CLINIC=$G(^PS(53.1,+PSJORD,"DSS")),APPT=$P(CLINIC,"^",2),C
          LINIC=$P(CLINIC,"^") I $$PATCH^XPDUTL("SD*5.3*285"),$$SDIMO^SDAMA203(C
          LINIC,DFN)>-1 Q
         ... Q:'PSJPDD  W !!,"Cannot process an Out-patient Unit Dose order for 
          ",$P($G(^DPT(+PSGP,0)),U) D PAUSE^VALM1 S PSJIVFLG=1
         ..NEW PSGRSD,PSGRSDN,PSGRFD,PSGRFDN
         ..D REQDT^PSJLIVMD(PSJORD)
         ..I $P(PSJXX1,U,4)="U",($G(PSGSCH)="") W !!,"Invalid schedule, can't fi
          nish this order" D PAUSE^VALM1 Q
         ..I $P(PSJXX1,U,4)="U" N PSJLM,PSJOCFG S PSJLM=1,PSGORD=PSJORD,PSJOCFG=
          "FN UD" D START^PSGOEF,ENSFE^PSGOEE0(PSGP,PSGORD) S:$G(PSJTUD) PSJOCFG
          ="FN UD" D @$S($G(PSJTUD):"FINISH^PSGOEF",1:"EN^VALM(""PSJ LM PENDING 
          EDIT"")") K PSJOCFG Q
         ..I $P(PSJXX1,U,4)'="U",PSGP=$P(PSJXX1,U,15),DFN=$P(PSJXX1,U,15) S PSJL
          YN=PSJORD,PSJOCFG="FN IV" D EN^PSJLIFN S PSJIVFLG=1 K PSJLYN,PSJMAI,PS
          JOCFG
         I $G(PSIVFLG) K PSIVFLG Q
         S PSGACT=$$ENACTION^PSGOE1(PSGP,PSJORD),PSGOEEF=0 D GETUD^PSJLMGUD(PSGP
          ,PSJORD),ENSFE^PSGOEE0(PSGP,PSJORD),EN^VALM("PSJ LM UD ACTION")
         I PSJORD["P" L -^PS(53.1,+PSJORD)
         I PSJORD["U" L -^PS(55,PSGP,5,+PSJORD)
         ;Send SN to CPRS if auto-verify OFF and Order Set Entry and no 21st pie
          ce
         S PSGOEAV=$P(PSJSYSP0,"^",9)&PSJSYSU
         I $D(PSGOES),'PSGOEAV,$D(PSGORD),PSGORD["P",$P($G(^PS(53.1,+PSGORD,0)),
          "^",21)']"" D ORSET^PSGOETO1
         I $G(PSGOEAV),($G(PSGOES)=1) D SETOC ;Store allergy for order set /w au
          to vf 
         I '$G(PSGOEAV),($G(PSJORD)["P"),$S($G(PSJAGYSV):1,($G(PSJOCFG)="NEW UD"
          ):1,1:0) D SETOC
         D UNL^PSSLOCK(PSGP,PSJORD)
         Q
SETOC    ;
         ;RTC 178789 
         S ^TMP("PSODAOC",$J,"IP IEN")=PSJORD
         D SETOC^PSJNEWOC(PSJORD)
         K ^TMP("PSODAOC",$J),^TMP("PSJDAOC",$J),PSJAGYSV,PSJOCFG
         Q
EDIT(PSGP,PSGORD,PROMPT) --
          ;
         I "DE"[$$GTSTATUS(PSGP,PSGORD) W !,"This order may not be edited." D PA
          USE^VALM1 Q
         I PSGACT'["E" W !,"This order may not be edited." D PAUSE^VALM1 Q
         N PSJEDITO S PSJEDITO=1
         S PSJAGYSV=1 ;Flag to store allergy data in 100.05.
         S PSGNEDFD="" D HOLDHDR,@$S('PROMPT:"ENEFA2^PSGON",1:"ENEFA^PSGON") I '
          Y D ABORT^PSGOEE Q
         I PSGORD["P" D ENF^PSGOEE Q
         D ACT^PSGOEE
         Q
RENEW(PSGP,PSGORD) --
          ;
         ;PSJOCFG - If defined, it's for new order, renew or copy. ^PSJOCDSD usi
          ng this flag to not display drug error.
         NEW PSJOCFG
         S PSJOCFG="RENEW UD"
         D HOLDHDR
         I 'PSJSYSU,$P($G(^PS(55,PSGP,5,+PSGORD,4)),U,15),$P($G(^(4)),U,16) W !!
          ,"This order is already marked for renewal!" D PAUSE^VALM1 S VALMBCK="
          R" Q
         I 'PSGRRF D ^PSGOER K PSJOCFG Q
         D ^PSGOERI
         K PSJOCFG
         Q
GTSTATUS(DFN,ON) --
            ;
         I ON["P" Q $P($G(^PS(53.1,+ON,0)),U,9)
         I ON["U" Q $P($G(^PS(55,DFN,5,+ON,0)),U,9)
         Q $P($G(^PS(55,DFN,"IV",+ON,0)),U,17)
DC(DFN,PSJORD) --
          ; DC IV, UD, or pending orders.
         D HOLDHDR
         S X=$$GTSTATUS(DFN,PSJORD) I X="D"!(X="DE")!(X="R") W !,$S(X="R":"This 
          order has a pending renewal and cannot be DISCONTINUED.",1:"This order
           has already been DISCONTINUED.") D PAUSE^VALM1 Q
         D ENO^PSGOEC(DFN,PSJORD) ;,GETUD^PSJLMGUD(DFN,PSJORD),INIT^PSJLMUDE(DFN
          ,PSJORD) S VALMBCK="Q"
         S VALMBCK="Q"
         Q
HOLD(DFN,PSJORD) --
          ; Change order's status from ACTIVE<->HOLD
         D HOLDHDR
         I PSJORD["V" D H^PSIVOPT(DFN,PSJORD,P(17),P(3))
         I PSJORD'["V" D H^PSGOE1(DFN,PSJORD)
         D GETUD^PSJLMGUD(DFN,PSJORD),INIT^PSJLMUDE(DFN,PSJORD) S PSGACT=$$ENACT
          ION^PSGOE1(DFN,PSJORD),VALMBCK="R"
         Q
COPY(PSGP,PSGORD) --
           ; Copy an order (does not discontinue original order)
         NEW PSJOCFG
         I $D(PSGCOPY) W !!,"You cannot copy the order at this time" D PAUSE^VAL
          M1 Q
         I PSGORD["P" W !!,"You cannot copy this "_$S($G(PSGSTAT)]"":PSGSTAT,1:"
          PENDING IV")_" order." D PAUSE^VALM1 Q
         I PSGORD["V" D  Q
         .I $G(PSIVCOPY) W !!,"You cannot copy the order at this time" D PAUSE^V
          ALM1 Q
         .S PSJOCFG="COPY IV"
         .D COPY^PSIVOD(PSGP,PSGORD) K PSJOCFG Q
         Q:'$$HIDDEN^PSJLMUTL("COPY")
         D ^PSJHVARS
         I $P($G(^PS(55,PSGP,5,+PSGORD,.2)),U,4)="D",'$P($G(^(4)),"^",3) W !!,"N
          urse verified orders with a priority of DONE may not be Copied." D PAU
          SE^VALM1 Q
         S PSJOCFG="COPY UD"
         S PSGOEAV=$P(PSJSYSP0,U,9)&PSJSYSU
         S PSGCOPY=1
         D FULL^VALM1,^PSGOD
         S VALMBCK="R"
         K PSGCOPY,PSJOCFG
         S PSGACT=$$ENACTION^PSGOE1(PSGP,PSGORD) ; resets PSGACT after copy
         I $G(PSGPXN) N PSGTMPXN S PSGTMPXN=PSGPXN
         D RESTORE^PSJHVARS I $G(PSGTMPXN) S PSGPXN=PSGTMPXN
         Q
UPDATE   ; Refresh array, actions, & display.
         D GETUD^PSJLMGUD(DFN,ON),INIT^PSJLMUDE(DFN,ON) S VALMBCK="R"
         Q
FINISH   ;
         D FINISH^PSGOEF,PAUSE^VALM1
         Q
LOG(DFN,PSGORD) --
                 ;
         D FULL^VALM1,ENLM^PSGOEL(DFN,PSGORD),PAUSE^VALM1 S VALMBCK="R"
         Q
NEWSEL   ;
         N PSGLMT,PSGODDD,PSJLMQT,PSJLMFIN,PSJUDPRF,PSGRDTX,PSJOCDSC,PSJAGYSV K 
          ^TMP("PSJCOM",$J),^TMP("PSJCOM2",$J),^TMP("PSODAOC",$J),^TMP("PSJDAOC"
          ,$J)
         ;; START NCC REMEDIATION >> 327*RJS +-   
         S IOTM=VALM("TM"),IOBM=IOSL W IOSC W @IOSTBM W IORC
         ;; END NCC REMEDIATION << 327*RJS
         S X=$P(XQORNOD(0),"=",2)
         S PSGONC=1,PSGLMT=^TMP("PSJPRO",$J,0)
         D ENCHK^PSGON I '$O(PSGODDD(0)) S VALMQUIT=1 Q
         S PSJLM=1,PSJSEL=0 F  S PSJSEL=$O(PSGODDD(PSJSEL)) Q:'PSJSEL  F PSJSEL1
          =1:1:$L(PSGODDD(PSJSEL),",")-1 D
         .K PSJOCDSC,PSGDRG
         .S PSJORD=$G(^TMP("PSJON",$J,+$P(PSGODDD(PSJSEL),",",PSJSEL1))) D:PSJOR
          D=+PSJORD SELECT^PSJOEA
         .Q:PSJORD=+PSJORD 
         .Q:PSJORD=""!($G(Y)<0)  Q:('$$LS^PSSLOCK(PSGP,PSJORD))  D
         ..S PSGORD=""
         ..S ON=PSJORD
         ..D DISACTIO(PSGP,PSJORD,$G(PSJPNV)) S:PSJORD["V" PSJORD=ON
         ..D UNL^PSSLOCK(PSGP,PSJORD)
         ..I $G(PSJNOL) K PSJNOL I $D(ON),ON'=PSJORD D UNL^PSSLOCK(PSGP,ON)
         ..Q:$G(Y)<0
         I '$G(PSGOEAV),($G(PSJORD)["P"),$G(PSJAGYSV) D
         .;RTC 178789 
         .S ^TMP("PSODAOC",$J,"IP IEN")=PSJORD
         .D SETOC^PSJNEWOC(PSJORD)
         .K ^TMP("PSODAOC",$J),^TMP("PSJDAOC",$J),PSJAGYSV
         S VALMBCK="Q"
         K PSJLM,PSJOCDSC
         Q
HOLDHDR  ; Freeze header text while processing order actions
         I $D(VALM("TM")) S IOTM=VALM("TM"),IOBM=IOSL W IOSC W @IOSTBM W IORC
         Q
LOCKERR  ;
         W !!,$C(7),"You are entering or editing an Inpatient Medication order i
          n another session.",!,"Only one order entry/edit session is allowed fo
          r a user at a time.",!! N DIR S DIR(0)="E" D ^DIR
         Q
FLAG(DFN,PSJORD) --
          ;Flag order through CPRS entry point.
         N ORIFN,NODE0
         S NODE0=$S(PSJORD["V":$G(^PS(55,DFN,"IV",+PSJORD,0)),PSJORD["U":$G(^PS(
          55,DFN,5,+PSJORD,0)),1:^PS(53.1,+PSJORD,0))
         S ORIFN=$P(NODE0,"^",21)
         D EN1^ORCFLAG(ORIFN)
         D PAUSE^VALM1
         Q
COMPLEX(DFN,ON) --
          ;
         N NDP2,COM
         S NDP2=$S(ON["P":$G(^PS(53.1,+ON,.2)),ON["U":$G(^PS(55,DFN,5,+ON,.2)),O
          N["V":$G(^PS(55,DFN,"IV",+ON,.2)),1:"")
         S COM=$P(NDP2,"^",8) I COM Q 1
         Q 0
CLOZSND  ; SEND CLOZAPINE OVERRIDE MESSAGE AND ORDER TO HINES DB
         ;; START NCC REMEDIATION >> 327*RJS
         S PSJYSCL=0
         I $D(YSCLR),$P(YSCLR,"^",4)>1500 N PSJYSCL S PSJYSCL=1 ;; NCC REMEDITAT
          ION RTW
         I PSJYSCL'=1,$D(^PSDRUG("ACLOZ",+PSGDN)) D PSJFILE^PSJCLOZ(DFN),INPSND^
          YSCLTST5
         S PSJYSCL=1
         ;; END NCC REMEDIATION << 327*RJS
         Q

*****   INDEX OF PSJOE   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
   AC           DONE+3!
   ACTION       DONE+3!
>> ANQX         DISACTIO+16*,DISACTIO+17
>> APPT         DISACTIO+32*
>> CLINIC       DISACTIO+32*
   COM          COMPLEX+1~,COMPLEX+3*
   D1           DONE+3!
   D2           DONE+3!
   DA           DONE+4!
   DFN          EN+4*,EN+21~,EN+25*,HK+2~*,HK+5*,DISACTIO~,DISACTIO+8
                DISACTIO+9,DISACTIO+10,DISACTIO+24,DISACTIO+32,DISACTIO+38
                GTSTATUS~,GTSTATUS+2,GTSTATUS+3,DC~,DC+2,DC+3,HOLD~,HOLD+2
                HOLD+3,HOLD+4,UPDATE+1,LOG~,LOG+1,FLAG~,FLAG+2,COMPLEX~
                COMPLEX+2
                CLOZSND+4
   DIR          DISACTIO+17!,DISACTIO+22!,LOCKERR+1~
   DIR(0        DISACTIO+17*,DISACTIO+22*,LOCKERR+1*
   DIU          DONE+6!
   DRG          DONE+4!
   DRGI         DONE+6!
   FLAG         DONE+6!
   FQC          DONE+6!
>> IOBM         NEWSEL+3*,HOLDHDR+1*
>> IORC         NEWSEL+3,HOLDHDR+1
>> IOS          EN+24
>> IOSC         NEWSEL+3,HOLDHDR+1
   IOSL         NEWSEL+3,HOLDHDR+1
>> IOSTBM       NEWSEL+3,HOLDHDR+1
>> IOTM         NEWSEL+3*,HOLDHDR+1*
   MI           DONE+3!
   N            DONE+3!
   ND2          DONE+6!
   NDP2         COMPLEX+1~,COMPLEX+2*,COMPLEX+3
   NE           DONE+4!
   NODE0        FLAG+1~,FLAG+2*,FLAG+3
   NXTPT        EN+8~*,EN+16*,EN+17*,EN+18*
   ON           DONE+3!,SELECT+11,DISACTIO+28~*,GTSTATUS~,GTSTATUS+1,GTSTATUS+2
                GTSTATUS+3,UPDATE+1,NEWSEL+14*,NEWSEL+15,NEWSEL+17,COMPLEX~
                COMPLEX+2
   ON55         DISACTIO+7~
   ORIFN        FLAG+1~,FLAG+3*,FLAG+4
>> P("PON"      DISACTIO+27*
>> P(17         HOLD+2
>> P(3          HOLD+2
   P3           DONE+3!
   PNOW         DONE+3!
   PRI          DONE+6!
   PROMPT       EDIT~,EDIT+5
>> PSGACT       DISACTIO+23*,DISACTIO+40*,EDIT+2,HOLD+4*,COPY+17*
   PSGCANFL     DONE+4!
   PSGCF        DONE+4!
   PSGCOPY      COPY+2,COPY+13*,COPY+16!
>> PSGDN        CLOZSND+4
   PSGDRG       DISACTIO+14*,DISACTIO+16,NEWSEL+9!
   PSGFDX       DISACTIO+7~
   PSGLMT       SELECT+2~,SELECT+3*,NEWSEL+1~,NEWSEL+6*
   PSGNEDFD     DONE+4!,EDIT+5*
   PSGNEF       EN+3*,DONE+4!
   PSGNEFD      DONE+4!
   PSGNEPR      DONE+4!
   PSGNESD      DONE+4!
   PSGODDD      SELECT+2~,NEWSEL+1~
   PSGODDD(     SELECT+5,SELECT+7,NEWSEL+8,NEWSEL+10
   PSGODDD(0    NEWSEL+7
   PSGOE        DONE+6!
   PSGOEA       DONE+4!
   PSGOEAV      EN+3*,DONE+4!,DISACTIO+11*,DISACTIO+44*,DISACTIO+45,DISACTIO+46
                DISACTIO+47,COPY+12*,NEWSEL+19
   PSGOEDMR     DONE+6!
>> PSGOEEF      DISACTIO+40*
   PSGOENG      DISACTIO+19!,DISACTIO+20*,DISACTIO+21*,DISACTIO+22*
   PSGOEORF     DONE+5!
   PSGOEPR      DONE+6!
>> PSGOES       DISACTIO+45,DISACTIO+46
   PSGOL        DONE+4!
   PSGON        DONE+4!
>> PSGONC       SELECT+3*,NEWSEL+6*
   PSGOP        EN+3*,DONE+4!,HK+1,HK+2,HK+5*
   PSGORD       DONE+4!,SELECT+10*,DISACTIO+37*,DISACTIO+45,EDIT~,EDIT+1,EDIT+6
                RENEW~,RENEW+5,COPY~,COPY+3,COPY+4,COPY+7,COPY+10,COPY+17,LOG~
                LOG+1,NEWSEL+13*
   PSGOS        DONE+4!
   PSGP         EN+4,EN+6,EN+20,EN+21~,EN+25*,HK+1,HK+4,HK+5,SELECT+8,SELECT+11
                SELECT+12,DISACTIO+7~,DISACTIO+9*,DISACTIO+16,DISACTIO+20
                DISACTIO+23,DISACTIO+24,DISACTIO+33,DISACTIO+37,DISACTIO+38
                DISACTIO+40,DISACTIO+42,DISACTIO+48,EDIT~,EDIT+1
                RENEW~,RENEW+5,COPY~,COPY+7,COPY+10,COPY+17,NEWSEL+12,NEWSEL+15
                NEWSEL+16,NEWSEL+17
>> PSGPD        DISACTIO+12*,DISACTIO+14
>> PSGPDN       DISACTIO+12*
>> PSGPRF       DISACTIO+19
   PSGPRI       DONE+6!
>> PSGPTMP      EN+4*
   PSGPTS       DONE+6!
>> PSGPXN       EN+3*,EN+20*,DONE+8,COPY+18,COPY+19*
   PSGPXPT      EN+20*!,EN+25
   PSGRDTX      EN+9!,SELECT+2~,NEWSEL+1~
   PSGRFD       DISACTIO+34~
   PSGRFDN      DISACTIO+34~
>> PSGRRF       RENEW+6
   PSGRSD       DISACTIO+34~
   PSGRSDN      DISACTIO+34~
   PSGS0XT      DONE+4!
   PSGS0Y       DONE+4!
>> PSGSCH       DISACTIO+36
   PSGSDN       DONE+6!
   PSGSDX       DISACTIO+7~
>> PSGSTAT      DISACTIO+15,COPY+3
   PSGTMPXN     COPY+18~*,COPY+19
   PSGTOL       DONE+6!
   PSGTOO       DONE+6!
   PSGUOW       DONE+6!
   PSGVBY       EN+3!
   PSIVAT       DONE+3!
>> PSIVCOPY     COPY+5
   PSIVENO      DONE+7!,DISACTIO+7~
   PSIVFLG      DISACTIO+27*,DISACTIO+39!
   PSIVLN       DONE+3!
   PSIVREA      DONE+5!
   PSIVSTR      DONE+3!
   PSJACNWP     HK+2~
   PSJACOK      EN+3*,DONE+4!
   PSJACPF      HK+2~,HK+3*
   PSJAGYSV     DONE+2!,SELECT+2~,DISACTIO+47,SETOC+4!,EDIT+4*,NEWSEL+1~
                NEWSEL+19,NEWSEL+23!
>> PSJCOI       DISACTIO+12
>> PSJCOM       EN+20
   PSJCT        DONE+5!
   PSJDSVFY     DISACTIO+7~
   PSJEDITO     EDIT+3~*
   PSJENHOC     DISACTIO+7~
   PSJEXCPT     DONE+2!
   PSJIVFLG     DISACTIO+7~,DISACTIO+25,DISACTIO+31,DISACTIO+33*,DISACTIO+38*
   PSJIVOF      DONE+6!
   PSJIVORF     DONE+4!
   PSJIVPCL     DONE+4!
   PSJLK        EN+1~,EN+4,EN+6*
   PSJLM        DONE+5!,SELECT+5*,SELECT+14!,DISACTIO+37~*,NEWSEL+8*,NEWSEL+25!
   PSJLMCON     EN+1~,EN+4*,EN+10,EN+12*,EN+14,EN+15*
   PSJLMFIN     SELECT+2~,NEWSEL+1~
   PSJLMPRO     EN+7!,EN+12*,EN+14,EN+15*,EN+27!
   PSJLMQT      SELECT+2~,NEWSEL+1~
   PSJLYN       DISACTIO+38*!
   PSJMAI       DISACTIO+38!
   PSJNEWOE     EN+1~,EN+10,EN+12*,EN+13*,EN+16,EN+18*
   PSJNOL       NEWSEL+17!
   PSJOCDSC     SELECT+2~,SELECT+6!,SELECT+14!,NEWSEL+1~,NEWSEL+9!,NEWSEL+25!
   PSJOCER      DONE+2!
   PSJOCFG      DISACTIO+37~*!,DISACTIO+38*!,DISACTIO+47,SETOC+4!,RENEW+2~
                RENEW+3*,RENEW+6!,RENEW+8!,COPY+1~,COPY+6*,COPY+7!,COPY+11*
                COPY+16!
   PSJOCNT      DONE+6!
   PSJOE        DONE+4!
   PSJOECNT     DONE+4!
   PSJOEPF      DONE+4!
>> PSJOL        EN+3*,EN+11*,EN+19*
   PSJON        DONE+6!
   PSJOPC       DONE+5!
   PSJORD       DONE+4!,SELECT+7*,SELECT+8,SELECT+9,SELECT+11*,SELECT+12
                DISACTIO~,DISACTIO+8,DISACTIO+9,DISACTIO+10,DISACTIO+20
                DISACTIO+21,DISACTIO+23,DISACTIO+24,DISACTIO+25,DISACTIO+27
                DISACTIO+28,DISACTIO+32,DISACTIO+35,DISACTIO+37,DISACTIO+38
                DISACTIO+40,DISACTIO+41,DISACTIO+42,DISACTIO+47,DISACTIO+48
                SETOC+2,SETOC+3,DC~,DC+2,DC+3,HOLD~,HOLD+2,HOLD+3,HOLD+4
                NEWSEL+10*,NEWSEL+11,NEWSEL+12,NEWSEL+14,NEWSEL+15*,NEWSEL+16
                NEWSEL+17,NEWSEL+19,NEWSEL+21,NEWSEL+22,FLAG~,FLAG+2
   PSJORL       DONE+5!
   PSJORPCL     DONE+5!
   PSJORQF      DONE+6!
   PSJORTOI     DONE+5!
   PSJORTOU     DONE+6!
   PSJORVP      DONE+6!
>> PSJPDD       DISACTIO+33
   PSJPDXP      EN+22*,EN+25!
   PSJPNV       DISACTIO~,NEWSEL+15
   PSJPR        EN+3!
   PSJPROT      EN+1~,EN+4*
   PSJPWD       HK+2~,HK+3*
   PSJPXDP      EN+21~
>> PSJSEL       SELECT+5*,SELECT+7,NEWSEL+8*,NEWSEL+10
>> PSJSEL1      SELECT+5*,SELECT+7,NEWSEL+8*,NEWSEL+10
   PSJSTARI     SELECT+2!
   PSJSYSL      HK+2~,HK+3
>> PSJSYSP      EN+3,DONE+3
>> PSJSYSP0     DISACTIO+11,DISACTIO+44,COPY+12
>> PSJSYSU      DISACTIO+11,DISACTIO+44,RENEW+5,COPY+12
   PSJSYSW      HK+2~
   PSJSYSW0     EN+20,EN+22,EN+24*,EN+25*,HK+2~
>> PSJTUD       DISACTIO+12,DISACTIO+30,DISACTIO+37
   PSJUDPRF     SELECT+2~,NEWSEL+1~
   PSJXX1       DISACTIO+7~,DISACTIO+24*,DISACTIO+25*,DISACTIO+26,DISACTIO+29
                DISACTIO+30*,DISACTIO+31,DISACTIO+36,DISACTIO+37,DISACTIO+38
   PSJYSCL      CLOZSND+2*,CLOZSND+3~*,CLOZSND+4,CLOZSND+5*
   RCT          DONE+4!
   RF           DONE+5!
   ST           DONE+4!
   U            EN+6,EN+20,EN+22,EN+24,EN+25,DISACTIO+24,DISACTIO+25
                DISACTIO+26,DISACTIO+29,DISACTIO+30,DISACTIO+31,DISACTIO+33
                DISACTIO+36,DISACTIO+37,DISACTIO+38,RENEW+5,GTSTATUS+1
                GTSTATUS+2,GTSTATUS+3,COPY+10,COPY+12
   VAERR        HK+2~
   VAIN         HK+2~
   VAIN(4       HK+3
   VAIP         DISACTIO+32~
>> VALM("TM"    NEWSEL+3,HOLDHDR+1
>> VALMBCK      EN+13,SELECT+13*,RENEW+5*,DC+4*,HOLD+4*,COPY+15*,UPDATE+1*
                LOG+1*,NEWSEL+24*
   VALMEVL      EN+1~
>> VALMQUIT     SELECT+4*,NEWSEL+7*
   WD           DONE+4!
   WSCHADM      DONE+5!
>> X            HK+5*,SELECT+4,DC+2*,NEWSEL+5*
>> XQORNOD(0    NEWSEL+5
   XQORS        EN+1~
   XQUIT        EN+2!
   XREF         DONE+4!
>> Y            SELECT+5,SELECT+7,SELECT+12,DISACTIO+25,EDIT+5,NEWSEL+12
                NEWSEL+18
>> YSCLR        CLOZSND+3
   Z            DONE+4!

Global Variables  ( * Changed  ! Killed)
   ^DPT(               DISACTIO+33
   ^PS(53.1            DISACTIO+21,DISACTIO+24,DISACTIO+25,DISACTIO+32
                       DISACTIO+41,DISACTIO+45,GTSTATUS+1,FLAG+2,COMPLEX+2
   ^PS(53.45           EN+3,DONE+3
   ^PS(55              DISACTIO+20,DISACTIO+42,RENEW+5,GTSTATUS+2,GTSTATUS+3
                       COPY+10,FLAG+2,COMPLEX+2
   ^PSDRUG("ACLOZ"     DISACTIO+16,CLOZSND+4
   ^PSDRUG("ASP"       DISACTIO+14
   ^TMP("PSJ"          EN+5!,EN+14,EN+27!
   ^TMP("PSJCOM"       SELECT+2!,NEWSEL+1!
   ^TMP("PSJCOM2"      SELECT+2!,NEWSEL+1!
   ^TMP("PSJDAOC"      DONE+2!,SELECT+2!,SETOC+4!,NEWSEL+1!,NEWSEL+23!
   ^TMP("PSJON"        EN+27!,SELECT+7,NEWSEL+10
   ^TMP("PSJPRO"       EN+27!,SELECT+3,NEWSEL+6
   ^TMP("PSODAOC"      DONE+2!,SELECT+2!,SETOC+2*,SETOC+4!,NEWSEL+1!,NEWSEL+21*
                       NEWSEL+23!
   ^TMP($J             DONE+2!

Naked Globals
   ^(           DISACTIO+14
   ^(4          RENEW+5,COPY+10

Cache Objects
   NONE

Marked Items
   NONE

Label References
   $$GTSTATUS   EDIT+1,DC+2
   @(           DISACTIO+37,EDIT+5
   DISACTIO     SELECT+11,NEWSEL+15
   DONE         EN+2
   HK           EN+4
   HOLDHDR      EDIT+5,RENEW+4,DC+1,HOLD+1
   SETOC        DISACTIO+46,DISACTIO+47

External References
   HOME^%ZIS           EN+24
   ^DIR                DISACTIO+17,DISACTIO+22,LOCKERR+1
   EN1^ORCFLAG         FLAG+4
   ENQL^PSGLW          HK+3
   ^PSGOD              COPY+14
   $$ENACTION^PSGOE1   DISACTIO+23,DISACTIO+40,HOLD+4,COPY+17
   H^PSGOE1            HOLD+3
   ENO^PSGOEC          DC+3
   ABORT^PSGOEE        EDIT+5
   ACT^PSGOEE          EDIT+7
   ENF^PSGOEE          EDIT+6
   ENSFE^PSGOEE0       DISACTIO+37,DISACTIO+40
   FINISH^PSGOEF       FINISH+1
   START^PSGOEF        DISACTIO+37
   ENLM^PSGOEL         LOG+1
   ^PSGOER             RENEW+6
   ^PSGOERI            RENEW+7
   ORSET^PSGOETO1      DISACTIO+45
   ENASR^PSGON         SELECT+3
   ENCHK^PSGON         NEWSEL+7
   ^PSGPER             EN+25
   ^PSGPER1            DONE+8
   ENCV^PSGSETU        EN+1,EN+26
   ENIVKV^PSGSETU      DONE+8
   COPY^PSIVOD         COPY+7
   H^PSIVOPT           HOLD+2
   VF^PSIVORC2         DISACTIO+28
   ^PSIVXU             EN+1,EN+26
   ^PSJAC              EN+4
   ENIV^PSJAC          DISACTIO+9
   WP^PSJAC            HK+3
   CLOZ^PSJCLOZ        DISACTIO+16
   PSJFILE^PSJCLOZ     CLOZSND+4
   ^PSJHVARS           COPY+9
   RESTORE^PSJHVARS    COPY+19
   EN^PSJLIFN          DISACTIO+38
   EN^PSJLIORD         DISACTIO+9
   REQDT^PSJLIVMD      DISACTIO+35
   GETUD^PSJLMGUD      DISACTIO+10,DISACTIO+40,HOLD+4,UPDATE+1
   INIT^PSJLMUDE       HOLD+4,UPDATE+1
   $$HIDDEN^PSJLMUTL   COPY+8
   $$OINAME^PSJLMUTL   DISACTIO+12
   SETOC^PSJNEWOC      SETOC+3,NEWSEL+22
   DONE^PSJOE          EN+3
   LOCKERR^PSJOE       EN+3
   OLDCOM^PSJOE0       DISACTIO+8
   SELECT^PSJOEA       SELECT+7,NEWSEL+10
   ^PSJP               EN+4
   $$L^PSSLOCK         EN+6
   $$LS^PSSLOCK        SELECT+8,NEWSEL+12
   UL^PSSLOCK          EN+4
   UNL^PSSLOCK         SELECT+12,DISACTIO+48,NEWSEL+16,NEWSEL+17
   $$SDIMO^SDAMA203    DISACTIO+32
   INP^VADPT           HK+3
   EN^VALM             EN+7,EN+12,EN+15,DISACTIO+40
   FULL^VALM1          COPY+14,LOG+1
   PAUSE^VALM1         DISACTIO+33,DISACTIO+36,EDIT+1,EDIT+2,RENEW+5,DC+2
                       COPY+2,COPY+3,COPY+5,COPY+10,FINISH+1,LOG+1,FLAG+5
   $$PATCH^XPDUTL      DISACTIO+32
   INPSND^YSCLTST5     CLOZSND+4

*****   END   *****

   Press return to continue:

PSJRXLAB * *  121 Lines,  7782 Bytes, Checksum: B47487387
                                                  Jun 01, 2016@09:50:20 page 15
              1115 bytes in comments
PSJRXLAB ;ALB/RTW -  drug+lab result print ; 03/25/2016 10:06
         ;;5.0;INPATIENT PHARMACY;**327**;DEC 1997
         ;RTW copied from routine PSORXLAB and modified for the Inpatient NCC Cl
          ozapine inpatient pharmacy project
         ;FSIG and FSIG2(formerly EN2), are brought in from PSOUTLA and PSOUTLA1
           
         ;a routine which loop thru the last fill order of ^PS(55 and gets
         ;patients with a specific drug. then gets the lrdfn from the 
         ;patient file and loops thru the patients lab data to find
         ;results within the date range you specify for the lab test
         ;used to minitor the drug. it then prints the patient's name
         ;ssn, last fill date, and the lab test results if any.
         ;this is intended as a qa minitor and should not be run for
         ;more than a 30 day fill date interval, or 1 year lab test interval.
         ;External ref. to ^LAB(60, is supp. by DBIA# 333
         ;External ref. to ^LR(LRDFN,"CH", is supp. by DBIA# 844
         ;External ref. to ^PSDRUG( is supp. by DBIA# 221
         ;External ref. to ^VA(200, is supp. by DBIA# 10060
PSJSITE  K ^UTILITY("DIQ1",$J),DIQ S DA=$P($$SITE^VASITE(),"^")
         N PSCNT
         S PSCNT=0
         I $G(DA) D
         .S DIC=4,DIQ(0)="I",DR=".01;99" D EN^DIQ1
         .S SITE=$G(^UTILITY("DIQ1",$J,4,DA,.01,"I"))_" "_$G(^UTILITY("DIQ1",$J,
          4,DA,99,"I"))
         .K ^UTILITY("DIQ1",$J),DA,DR,DIQ,DIC
         S Y=DT X ^DD("DD") S SITE=$G(SITE)_" "_Y
BDATE    S %DT="EXTA",%DT("A")="Beginning fill date: " D ^%DT G CLEAN:Y<0 S PSJB
          D=Y X ^DD("DD") S PSJBDR=Y
EDATE    S %DT("A")="Ending last fill date: " D ^%DT G CLEAN:Y<0 S PSJED=Y X ^DD
          ("DD") S PSJEDR=Y
LDATE    S %DT("A")="Earliest date for lab results: " D ^%DT G CLEAN:Y<0 S LDATE
          =Y X ^DD("DD") S LDATER=Y
DRUG     R !,"Enter the key word in the Drug Generic name: ",PSJDRUG:DTIME G CLE
          AN:'$T I "^"[PSJDRUG G CLEAN
         I $O(^PSDRUG("B",$E(PSJDRUG,1,$L(PSJDRUG)-1)))'[PSJDRUG W !,"No corresp
          onding entry, try again or type return to exit" G DRUG
LABT     S DIC="^LAB(60,",DIC(0)="QEAM" D ^DIC K DIC G:Y<0 CLEAN S PSJLBT=$P(Y,"
          ^"),PSJLABTN=$P(Y,"^",2) G:PSJLBT="" CLEAN I $G(^LAB(60,PSJLBT,.2))']"
          " W !!,$C(7),"Data Name missing !!",! K Y,PSJLBT G LABT
         S PSJLABT=^LAB(60,PSJLBT,.2)
         W !,"Enter the specimen used in the lab for this test, serum,plasma,blo
          od etc."
PSJSP    S DIC="^LAB(61,",DIC(0)="QEAM" D ^DIC G:Y<0 CLEAN S PSJSP=$P(Y,"^") G:P
          SJSP="" CLEAN ;;I $P($G(^LAB(60,PSJLBT,1,PSJSP,0)),"^",7)']"" W !!,$C(
          7),"Specimen data missing !!",! ;K Y,PSJSP G PSJSP
PSJUNIT  S PSJUNIT=$S($G(PSJSP)]"":$P($G(^LAB(60,PSJLBT,1,PSJSP,0)),"^",7),1:"")
PSJANS   R !,"Do you want Order info? N// ",PSJANS:DTIME G CLEAN:'$T S:PSJANS=""
           PSJANS="N" G:PSJANS="^" CLEAN2 I "YN"'[PSJANS W !,"ANSWER YES OR NO" 
          G PSJANS
DEVICE   K IOP S %ZIS="MQ" D ^%ZIS G:POP CLEAN2
         I $D(IO("Q")) K IO("Q") S ZTSAVE("*")="",ZTRTN="DQ^PSJRXLAB",ZTDESC="LA
          B LIST" D ^%ZTLOAD K ZTSK G CLEAN
DQ       S PSJLABQ=0 S PSJBD=PSJBD-1,PAGE=0 U IO W @IOF D HDR
LOOP1    N PSJ F PSJ=0:0 S PSJBD=$O(^OR(100,"AD",PSJBD)) Q:PSJBD=""!($G(PSJLABQ)
          )  Q:PSJBD>PSJED  S PSJORDN=0 D LOOP2
         G CLEAN
LOOP2    N PSJ2 F PSJ2=0:0 S PSJORDN=$O(^OR(100,"AD",PSJBD,PSJORDN)) Q:PSJORDN="
          "!($G(PSJLABQ))  D:$G(^OR(100,PSJORDN,0))]"" CHECK1
         Q
CHECK1   ;
         N PSJNUM
         S PSCNT=PSCNT+1
         S ^TMP("ORDERNUM",PSCNT)=PSJORDN
         S PSJNUM=0 F  S PSJNUM=$O(^OR(100,PSJORDN,4.5,PSJNUM)) Q:'PSJNUM  D
         . I $P(^OR(100,PSJORDN,4.5,PSJNUM,0),"^",4)["DRUG" D
         . . S PSJDGN=$P($G(^OR(100,PSJORDN,4.5,PSJNUM,1)),"^",1),PSJDRUGN=$P($G
          (^PSDRUG(PSJDGN,0)),"^")
         Q:'$D(PSJDGN)
         I PSJDRUGN'[PSJDRUG Q
         Q:'$P($G(^OR(100,PSJORDN,0)),"^",4)  S PSJPROV=$P(^OR(100,PSJORDN,0),"^
          ",4),PSJPROVN=$P(^VA(200,PSJPROV,0),"^"),PSJPROT=$P(^VA(200,PSJPROV,0)
          ,"^",5)
         S PSJTYPE="NONE" I PSJPROT S PSJTYPE=$P("FULL TIME^PART TIME^C & A^FEE^
          STAFF","^",PSJPROT)
CHECK2   Q:'$P($G(^OR(100,PSJORDN,0)),"^",2)
         S (PSJPT)=+$P(^OR(100,PSJORDN,0),"^",2) W ! D PID^VADPT,PRINT2
         I '$D(^DPT(PSJPT,"LR")) W ?55,"No lab data exists",?81,$E(PSJPROVN,1,20
          ),?106,PSJTYPE,! D:PSJANS["Y" PSJORDNI Q
         S LRDFN=$P(^DPT(PSJPT,"LR"),"^"),PSJLBENT=0,PSJINDIC=0
LOOP3    F J2=0:0 S PSJLBENT=$O(^LR(LRDFN,"CH",PSJLBENT)) Q:PSJLBENT=""!($G(PSJL
          ABQ))  S PSJLDATE=$P(^LR(LRDFN,"CH",PSJLBENT,0),"^") Q:PSJLDATE<LDATE 
           D CHECK3
         I PSJINDIC=0 W ?55,"NO LAB DATA IN RANGE",?81,$E(PSJPROVN,1,20),?106,PS
          JTYPE,!
         D:PSJANS["Y" PSJORDNI
         Q
CHECK3   I $D(^LR(LRDFN,"CH",PSJLBENT,PSJLABT)) D RESULT
         Q
RESULT   Q:$P(^LR(LRDFN,"CH",PSJLBENT,0),"^",5)'=PSJSP  Q:'$P(^(0),"^",3)
         S Y=PSJLDATE X ^DD("DD") W ?55,$E(Y,1,11),?70,$P(^LR(LRDFN,"CH",PSJLBEN
          T,PSJLABT),"^")_" "_PSJUNIT,?81,$E(PSJPROVN,1,20),?106,PSJTYPE W !
         S PSJINDIC=1 Q
         Q
PRINT2   I $Y>(IOSL-6) D  Q:$G(PSJLABQ)  W @IOF,SITE,! D HDR2
         .I $E(IOST)="C" K DIR S DIR(0)="E" D ^DIR S:$D(DTOUT)!($D(DUOUT)) PSJLA
          BQ=1
         W ?1,$E($P(^DPT(PSJPT,0),"^"),1,20),?25,VA("PID") S Y=PSJBD X ^DD("DD")
           W ?43,Y Q
HDR      W SITE,!!,"Patients receiving "_PSJDRUG_" with fills between "_PSJBDR_"
           and "_PSJEDR,!," with date of collection and results for lab test "_P
          SJLABTN_" after ",LDATER,!
HDR2     S PAGE=PAGE+1 W !,"Name",?25,"ID#",?43,"Fill Date",?55,"Lab Date",?71,"
          Results",?81,"Order Provider",?106,"Type",?116,"Page "_PAGE,!
         F J=1:1:IOM-1 W "_"
         W ! Q
PSJORDNI N DTOUT,DUOUT Q:$G(PSJLABQ)  W "Order #: "_$P(^OR(100,PSJORDN,0),"^")_"
             Drug: "_$P(^PSDRUG(PSJDGN,0),"^")
         K FSIG,BSIG I $P($G(^OR(100,PSJORDN,4.5,5,1)),"^") D FSIG("O",PSJORDN,7
          2) F PSREV=1:1 Q:'$D(FSIG(PSREV))  S BSIG(PSREV)=FSIG(PSREV)
         K FSIG,PSREV I '$P($G(^OR(100,PSJORDN,4.5,5,1)),"^") D FSIG2(PSJORDN,72
          )
         W !?1,"Sig: ",$G(BSIG(1))
         I $O(BSIG(1)) F PSREV=1:0 S PSREV=$O(BSIG(PSREV)) Q:'PSREV  W !?6,$G(BS
          IG(PSREV))
         I $Y>(IOSL-6) D  Q:$G(PSJLABQ)  W @IOF,SITE,! D HDR2
         .I $E(IOST)="C" K DIR S DIR(0)="E" D ^DIR S:$D(DTOUT)!($D(DUOUT)) PSJLA
          BQ=1
         W ! Q
CLEAN    W @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
CLEAN2   K PSJINDIC,PSJPT,PSJLDATE,PAGE,PSJBD,PSJBDR,PSJLBENT,PSJLABT,PSJDGN,PSJ
          DRUGN,PSJDRUG,J,J1,J2,PSJORDN,PSJPROV,PSJPROVN,LDATE,LDATER,PSJED,PSJE
          DR,PSJPROT,PSJTYPE,PSJLABTN,PSJLBT,PSJSP,PSJUNIT,PSJANS,DIC,LRDFN,POP,
          SITE,Y,%DT,PSJLABQ
         K ZTDESC,ZTRTN,ZTSAVE,%ZIS,^TMP("ORDERNUM") Q
FSIG(PSJFILE,PSJINTR,PSJLENTH) --
          ;Format front door sig
         ;PSJFILE is 'P' if in Pending File, 'R' if in Prescription File
         ;PSJINTR is internal number for either file
         ;PSJLENTH is length of each line of the Sig
         ;returned in the FSIG array
         K FSIG I $G(PSJFILE)=""!('$G(PSJINTR))!('$G(PSJLENTH)) G FQUIT
         I PSJFILE'="P",PSJFILE'="O" G FQUIT
         I PSJFILE="P",'$D(^PS(52.41,+PSJINTR,0)) G FQUIT
         I PSJFILE="O",'$D(^OR(100,+PSJINTR,0)) G FQUIT
         I PSJFILE="O",'$P($G(^OR(100,+PSJINTR,"SIG")),"^",2) G FQUIT
         N FFF,NNN,CNT,FVAR,FVAR1,FLIM,HSIG,II
         I PSJFILE="P" F NNN=0:0 S NNN=$O(^PS(52.41,PSJINTR,"SIG",NNN)) Q:'NNN  
          S:$G(^(NNN,0))'="" HSIG(NNN)=^(0)
         I PSJFILE="P" G:'$O(HSIG(0)) FQUIT G FSTART
         S FFF=1 F NNN=0:0 S NNN=$O(^OR(100,PSJINTR,"SIG1",NNN)) Q:'NNN  I $G(^(
          NNN,0))'="" S HSIG(FFF)=^(0) S FFF=FFF+1
         G:'$O(HSIG(0)) FQUIT
FSTART   S (FVAR,FVAR1)="",II=1
         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)>P
          SJLENTH S FSIG(II)=FLIM_" ",II=II+1,FVAR=FVAR1
         .S FVAR1=$P(HSIG(FFF)," ",(CNT))
         .S FLIM=FVAR
         .S FVAR=$S(FVAR="":FVAR1,1:FVAR_" "_FVAR1)
         I $G(FVAR)'="" S FSIG(II)=FVAR
         I $G(FSIG(1))=""!($G(FSIG(1))=" ") S FSIG(1)=$G(FSIG(2)) K FSIG(2)
FQUIT    Q
FSIG2(PSJBINTR,PSJBLGTH) --
          ;
         K BSIG
         N BBSIG,BVAR,BVAR1,III,CNT,NNN,BLIM
         S BBSIG=$P($G(^OR(100,PSJBINTR,"SIG")),"^") Q:BBSIG=""!($P($G(^("SIG"))
          ,"^",2))
         S (BVAR,BVAR1)="",III=1
         S CNT=0 F NNN=1:1:$L(BBSIG) I $E(BBSIG,NNN)=" "!($L(BBSIG)=NNN) S CNT=C
          NT+1 D  I $L(BVAR)>PSJBLGTH S BSIG(III)=BLIM_" ",III=III+1,BVAR=BVAR1
         .S BVAR1=$P(BBSIG," ",(CNT))
         .S BLIM=BVAR
         .S BVAR=$S(BVAR="":BVAR1,1:BVAR_" "_BVAR1)
         I $G(BVAR)'="" S BSIG(III)=BVAR
         I $G(BSIG(1))=""!($G(BSIG(1))=" ") S BSIG(1)=$G(BSIG(2)) K BSIG(2)
         Q
         ;

*****   INDEX OF PSJRXLAB   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
   %DT          BDATE*,CLEAN2!
   %DT("A"      BDATE*,EDATE*,LDATE*
   %ZIS         DEVICE*,CLEAN2+1!
   BBSIG        FSIG2+2~,FSIG2+3*,FSIG2+5,FSIG2+6
   BLIM         FSIG2+2~,FSIG2+5,FSIG2+7*
   BSIG         PSJORDNI+1!,FSIG2+1!
   BSIG(        PSJORDNI+1*,PSJORDNI+4,FSIG2+5*,FSIG2+9*
   BSIG(1       PSJORDNI+3,PSJORDNI+4,FSIG2+10*
   BSIG(2       FSIG2+10!
   BVAR         FSIG2+2~,FSIG2+4*,FSIG2+5*,FSIG2+7,FSIG2+8*,FSIG2+9
   BVAR1        FSIG2+2~,FSIG2+4*,FSIG2+5,FSIG2+6*,FSIG2+8
   CNT          FSIG+10~,FSTART+1*,FSTART+2,FSIG2+2~,FSIG2+5*,FSIG2+6
   DA           PSJSITE*,PSJSITE+3,PSJSITE+5,PSJSITE+6!
   DIC          PSJSITE+4*,PSJSITE+6!,LABT*!,PSJSP*,CLEAN2!
   DIC(0        LABT*,PSJSP*
   DIQ          PSJSITE!,PSJSITE+6!
   DIQ(0        PSJSITE+4*
   DIR          PRINT2+1!,PSJORDNI+6!
   DIR(0        PRINT2+1*,PSJORDNI+6*
   DR           PSJSITE+4*,PSJSITE+6!
   DT           PSJSITE+7
   DTIME        DRUG,PSJANS
   DTOUT        PRINT2+1,PSJORDNI~,PSJORDNI+6
   DUOUT        PRINT2+1,PSJORDNI~,PSJORDNI+6
   FFF          FSIG+10~,FSIG+13*,FSTART+1*,FSTART+2
   FLIM         FSIG+10~,FSTART+1,FSTART+3*
   FSIG         PSJORDNI+1!,PSJORDNI+2!,FSIG+5!
   FSIG(        PSJORDNI+1,FSTART+1*,FSTART+5*
   FSIG(1       FSTART+6*
   FSIG(2       FSTART+6!
   FVAR         FSIG+10~,FSTART*,FSTART+1*,FSTART+3,FSTART+4*,FSTART+5
   FVAR1        FSIG+10~,FSTART*,FSTART+1,FSTART+2*,FSTART+4
   HSIG         FSIG+10~
   HSIG(        FSIG+11*,FSIG+13*,FSTART+1,FSTART+2
   HSIG(0       FSIG+12,FSIG+14
   II           FSIG+10~,FSTART*,FSTART+1*,FSTART+5
   III          FSIG2+2~,FSIG2+4*,FSIG2+5*,FSIG2+9
   IO           DQ
   IO("Q"       DEVICE+1!
   IOF          DQ,PRINT2,PSJORDNI+5,CLEAN
   IOM          HDR2+1
   IOP          DEVICE!
   IOSL         PRINT2,PSJORDNI+5
   IOST         PRINT2+1,PSJORDNI+6
   J            HDR2+1*,CLEAN2!
   J1           CLEAN2!
   J2           LOOP3*,CLEAN2!
   LDATE        LDATE*,LOOP3,CLEAN2!
   LDATER       LDATE*,HDR,CLEAN2!
   LRDFN        CHECK2+3*,LOOP3,CHECK3,RESULT,RESULT+1,CLEAN2!
   NNN          FSIG+10~,FSIG+11*,FSIG+13*,FSTART+1*,FSIG2+2~,FSIG2+5*
   PAGE         DQ*,HDR2*,CLEAN2!
   POP          DEVICE,CLEAN2!
   PSCNT        PSJSITE+1~,PSJSITE+2*,CHECK1+2*,CHECK1+3
   PSJ          LOOP1~*
   PSJ2         LOOP2~*
   PSJANS       PSJANS*,CHECK2+2,LOOP3+2,CLEAN2!
   PSJBD        BDATE*,DQ*,LOOP1*,LOOP2,PRINT2+2,CLEAN2!
   PSJBDR       BDATE*,HDR,CLEAN2!
   PSJBINTR     FSIG2~,FSIG2+3
   PSJBLGTH     FSIG2~,FSIG2+5
   PSJDGN       CHECK1+6*,CHECK1+7,PSJORDNI,CLEAN2!
   PSJDRUG      DRUG*,DRUG+1,CHECK1+8,HDR,CLEAN2!
   PSJDRUGN     CHECK1+6*,CHECK1+8,CLEAN2!
   PSJED        EDATE*,LOOP1,CLEAN2!
   PSJEDR       EDATE*,HDR,CLEAN2!
   PSJFILE      FSIG~,FSIG+5,FSIG+6,FSIG+7,FSIG+8,FSIG+9,FSIG+11,FSIG+12
   PSJINDIC     CHECK2+3*,LOOP3+1,RESULT+2*,CLEAN2!
   PSJINTR      FSIG~,FSIG+5,FSIG+7,FSIG+8,FSIG+9,FSIG+11,FSIG+13
   PSJLABQ      DQ*,LOOP1,LOOP2,LOOP3,PRINT2,PRINT2+1*,PSJORDNI,PSJORDNI+5
                PSJORDNI+6*,CLEAN2!
   PSJLABT      LABT+1*,CHECK3,RESULT+1,CLEAN2!
   PSJLABTN     LABT*,HDR,CLEAN2!
   PSJLBENT     CHECK2+3*,LOOP3*,CHECK3,RESULT,RESULT+1,CLEAN2!
   PSJLBT       LABT*!,LABT+1,PSJUNIT,CLEAN2!
   PSJLDATE     LOOP3*,RESULT+1,CLEAN2!
   PSJLENTH     FSIG~,FSIG+5,FSTART+1
   PSJNUM       CHECK1+1~,CHECK1+4*,CHECK1+5,CHECK1+6
   PSJORDN      LOOP1*,LOOP2*,CHECK1+3,CHECK1+4,CHECK1+5,CHECK1+6,CHECK1+9
                CHECK2,CHECK2+1,PSJORDNI,PSJORDNI+1,PSJORDNI+2,CLEAN2!
   PSJPROT      CHECK1+9*,CHECK1+10,CLEAN2!
   PSJPROV      CHECK1+9*,CLEAN2!
   PSJPROVN     CHECK1+9*,CHECK2+2,LOOP3+1,RESULT+1,CLEAN2!
   PSJPT        CHECK2+1*,CHECK2+2,CHECK2+3,PRINT2+2,CLEAN2!
   PSJSP        PSJSP*,PSJUNIT,RESULT,CLEAN2!
   PSJTYPE      CHECK1+10*,CHECK2+2,LOOP3+1,RESULT+1,CLEAN2!
   PSJUNIT      PSJUNIT*,RESULT+1,CLEAN2!
   PSREV        PSJORDNI+1*,PSJORDNI+2!,PSJORDNI+4*
   SITE         PSJSITE+5*,PSJSITE+7*,PRINT2,HDR,PSJORDNI+5,CLEAN2!
>> VA("PID"     PRINT2+2
   Y            PSJSITE+7*,BDATE,EDATE,LDATE,LABT!,PSJSP,RESULT+1*,PRINT2+2*
                CLEAN2!
   ZTDESC       DEVICE+1*,CLEAN2+1!
>> ZTQUEUED     CLEAN
>> ZTREQ        CLEAN*
   ZTRTN        DEVICE+1*,CLEAN2+1!
   ZTSAVE       CLEAN2+1!
   ZTSAVE("*"   DEVICE+1*
   ZTSK         DEVICE+1!

Global Variables  ( * Changed  ! Killed)
   ^DD("DD"            PSJSITE+7,BDATE,EDATE,LDATE,RESULT+1,PRINT2+2
   ^DPT(               CHECK2+2,CHECK2+3,PRINT2+2
   ^LAB(60             LABT,LABT+1,PSJUNIT
   ^LR(                LOOP3,CHECK3,RESULT,RESULT+1
   ^OR(100             LOOP1,LOOP2,CHECK1+4,CHECK1+5,CHECK1+6,CHECK1+9,CHECK2
                       CHECK2+1,PSJORDNI,PSJORDNI+1,PSJORDNI+2,FSIG+8,FSIG+9
                       FSIG+13,FSIG2+3
   ^PS(52.41           FSIG+7,FSIG+11
   ^PSDRUG(            CHECK1+6,PSJORDNI
   ^PSDRUG("B"         DRUG+1
   ^TMP("ORDERNUM"     CHECK1+3*,CLEAN2+1!
   ^UTILITY("DIQ1"     PSJSITE!,PSJSITE+5,PSJSITE+6!
   ^VA(200             CHECK1+9

Naked Globals
   ^(           FSIG+11,FSIG+13
   ^("SIG"      FSIG2+3
   ^(0          RESULT,FSIG+11,FSIG+13

Cache Objects
   NONE

Marked Items
   NONE

Label References
   CHECK1       LOOP2
   CHECK3       LOOP3
   CLEAN        BDATE,EDATE,LDATE,DRUG,LABT,PSJSP,PSJANS,DEVICE+1,LOOP1+1
   CLEAN2       PSJANS,DEVICE
   DRUG         DRUG+1
   FQUIT        FSIG+5,FSIG+6,FSIG+7,FSIG+8,FSIG+9,FSIG+12,FSIG+14
   FSIG         PSJORDNI+1
   FSIG2        PSJORDNI+2
   FSTART       FSIG+12
   HDR          DQ
   HDR2         PRINT2,PSJORDNI+5
   LABT         LABT
   LOOP2        LOOP1
   PRINT2       CHECK2+1
   PSJANS       PSJANS
   PSJORDNI     CHECK2+2,LOOP3+2
   RESULT       CHECK3

External References
   ^%DT                BDATE,EDATE,LDATE
   ^%ZIS               DEVICE
   ^%ZISC              CLEAN
   ^%ZTLOAD            DEVICE+1
   ^DIC                LABT,PSJSP
   EN^DIQ1             PSJSITE+4
   ^DIR                PRINT2+1,PSJORDNI+6
   PID^VADPT           CHECK2+1
   $$SITE^VASITE       PSJSITE

*****   END   *****

   Press return to continue:

|dd53.8  * *  23 Lines,  566 Bytes, Checksum:     Jun 01, 2016@09:50:20 page 16
              269 bytes in comments
|dd53.8  ;DD of the CLOZAPINE MEDICATION OVERRIDES file.
.01      ; DATE TIME
         S %DT="ESTXR" D ^%DT S X=Y K:X<1 X
.01XRF1S ; SET LOGIC FOR 'B' XREF
         S ^PS(53.8,"B",$E(X,1,30),DA)=""
.01XRF1K ; KILL LOGIC FOR 'B' XREF
         K ^PS(53.8,"B",$E(X,1,30),DA)
1        ; ORDER NUMBER
         Q
1XRF1S   ; SET LOGIC FOR 'A' XREF
         S ^PS(53.8,"A",$E(X,1,30),DA)=""
1XRF1K   ; KILL LOGIC FOR 'A' XREF
         K ^PS(53.8,"A",$E(X,1,30),DA)
2        ; USER ENTERING
         Q
3        ; APPROVING TEAM MEMBER
         Q
4        ; REASON FOR OVERRIDE
         Q
5        ; COMMENTS
         K:$L(X)>200!($L(X)<5) X
6        ; SECOND APPROVING TEAM MEMBER
         Q

*****   INDEX OF |dd53.8   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
>> %DT          .01+1*
>> DA           .01XRF1S+1,.01XRF1K+1,1XRF1S+1,1XRF1K+1
   X            .01+1*!,.01XRF1S+1,.01XRF1K+1,1XRF1S+1,1XRF1K+1,5+1!
>> Y            .01+1

Global Variables  ( * Changed  ! Killed)
   ^PS(53.8            .01XRF1S+1*,.01XRF1K+1!,1XRF1S+1*,1XRF1K+1!

Naked Globals
   NONE

Cache Objects
   NONE

Marked Items
   NONE

Label References
   NONE

External References
   ^%DT                .01+1

*****   END   *****

   Press return to continue:

|opt     * *  14 Lines,  428 Bytes, Checksum:     Jun 01, 2016@09:50:20 page 17
              312 bytes in comments
|opt     ; 'Build file' Options.
         ;
2921741  ; PSJL MANAGER - Clozapine Inpatient Medications Manager (menu)
2921742  ; PSJLAB LIST - Display Inpatient Lab Tests and Results (run routine)
         ; ROUTINE
         D ^PSJRXLAB
2921744  ; PSJLIST OVERRIDES - List Inpatient Clozapine Overrides (run routine)
         ; ROUTINE
         D ^PSJCLOLS
1847     ; PSJU MGR - Unit Dose Medications (menu)
         ; EXIT ACTION
         D ENKV^PSGSETU
         ; ENTRY ACTION
         D ^PSGSET

*****   INDEX OF |opt   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
   NONE

Global Variables  ( * Changed  ! Killed)
   NONE

Naked Globals
   NONE

Cache Objects
   NONE

Marked Items
   NONE

Label References
   NONE

External References
   ^PSGSET             1847+4
   ENKV^PSGSETU        1847+2
   ^PSJCLOLS           2921744+2
   ^PSJRXLAB           2921742+2

*****   END   *****


--- CROSS-REFERENCING ALL ROUTINES ---
   Press return to continue:

*****   Cross Reference of all Routines   *****   Jun 01, 2016@09:50:20 page 18

Local Variables    Routines   ( >> not killed explicitly)
                              ( * Changed  ! Killed  ~ Newed)
   %            PSGOE41*,PSGOE42*,PSGOE7*!,PSGOE8*,PSGOE81*,PSGOE82*,PSGOE92*
                PSGOER,PSJCLOZ!
   %DT          PSGOE41*!,PSGOE81*!,PSGOER!,PSGOER0*!,PSJCLOLS*!,PSJRXLAB*!
                |dd53.8*
   %DT("A"      PSJCLOLS*,PSJRXLAB*
   %DT(0        PSGOE41*,PSGOE81*
   %X           PSGOEV*!
   %Y           PSGOE7!,PSGOEV*!
   %ZIS         PSJCLOLS*,PSJRXLAB*!
   %ZIS("B"     PSJCLOLS*
   AC           PSJOE!
   ACT          PSGOER*~
   ACTION       PSJOE!
>> ANOX         PSGOER0
   ANQDATA      PSJCLOZ!
   ANQREM       PSJCLOZ!
   ANQX         PSGOE42*!,PSGOE7*~,PSGOE8!,PSGOE82*,PSGOE92,PSGOER,PSGOER0!
                PSJCLOZ*,PSJOE*
   APP          PSGOE7~
>> APPT         PSJOE*
>> BACK         PSGOE8*,PSGOE81*,PSGOE82*,PSGOE92*
   BBSIG        PSJRXLAB*~
   BLIM         PSJRXLAB*~
   BSIG         PSJRXLAB!
   BSIG(        PSJRXLAB*
   BSIG(1       PSJRXLAB*
   BSIG(2       PSJRXLAB!
   BVAR         PSJRXLAB*~
   BVAR1        PSJRXLAB*~
   CHK          PSGOER*,PSGOEV*!,PSGOEV
>> CLINIC       PSJOE*
>> CLOZPAT      PSGOE41,PSGOE81,PSJCLOZ
   CNT          PSGOE7*~,PSJRXLAB*~
   COM          PSJOE*~
>> COMQUIT      PSGOER*,PSGOER0*
   CURDAT       PSGOER*~
   CUTOFF       PSGOER*~
   D            PSGOE7*,PSGOE8*!,PSGOER~
   D1           PSJOE!
   D2           PSJOE!
   DA           PSGOE42*!,PSGOE7!,PSGOE82*~,PSGOE92*~,PSGOER*!~,PSGOEV*!
                PSJCLOZ*!,PSJOE!,PSJRXLAB*!,|dd53.8
   DA(1         PSGOE7*,PSGOER*,PSGOEV*
   DA(2         PSGOER*
   DD           PSGOER!~,PSJCLOZ!
   DFN          PSGOE41,PSGOE8,PSGOE81,PSGOE92,PSGOER*~,PSGOEV~,PSJCLOZ~
                PSJOE*~,PSJOE
   DIC          PSGOE42*!,PSGOE7*!,PSGOE8*!,PSGOE82*!~,PSGOE92*!,PSGOER*!~
                PSGOER0*!,PSJCLOZ*!,PSJRXLAB*!
   DIC("A"      PSGOE7*
   DIC("DR"     PSGOER*
   DIC("P"      PSGOER*
   DIC("S"      PSGOE42*,PSGOE7*,PSGOE8*,PSGOE82*,PSGOE92*,PSGOER0*
   DIC("T"      PSGOE7*
   DIC(0        PSGOE42*,PSGOE7*,PSGOE8*,PSGOE82*,PSGOE92*,PSGOER*,PSGOER0*
                PSJCLOZ*,PSJRXLAB*
   DIE          PSGOE42*,PSGOE82*~,PSGOE92*~,PSGOER*!~,PSGOEV*!,PSJCLOZ*!
>> DINUM        PSGOER*
   DIQ          PSJRXLAB!
   DIQ(0        PSJRXLAB*
   DIR          PSGOE7!,PSGOE82~,PSGOER!,PSGOEV!~,PSJCLOZ!,PSJOE!~,PSJRXLAB!
   DIR("?"      PSGOER*
   DIR("A"      PSGOE7*,PSGOER*,PSGOEV*,PSJCLOZ*
   DIR("B"      PSGOER*,PSGOEV*,PSJCLOZ*
   DIR(0        PSGOE7*,PSGOER*,PSGOEV*,PSJCLOZ*,PSJOE*,PSJRXLAB*
   DIROUT       PSJCLOZ!
   DIRUT        PSGOER*,PSGOEV!~,PSJCLOZ!
   DIU          PSJOE!
   DLAYGO       PSJCLOZ*!
   DO           PSGOER!~,PSJCLOZ!
>> DOW          PSGOE8*
   DOWAT        PSGOER~
   DOWDFN       PSGOER~
   DOWFD        PSGOER~
   DOWSCH       PSGOER~
   DOWSD        PSGOER~
   DOWSTR       PSGOER*~
   DP           PSGOEV!
   DR           PSGOE42*!,PSGOE82*~,PSGOE92*~,PSGOER*!~,PSGOEV*!,PSJCLOZ*!
                PSJRXLAB*!
   DR(2         PSGOE42*,PSGOE82*,PSGOE92*
   DRG          PSGOE7~,PSGOER0,PSGOEV!~,PSJOE!
   DRGF         PSGOEV*!
   DRGI         PSJOE!
   DRUG         PSJCLOZ~
   DT           PSGOE7,PSGOE8,PSGOER0,PSGOEV,PSJRXLAB
   DTIME        PSGOE41,PSGOE42,PSGOE7,PSGOE8,PSGOE81,PSGOE82,PSGOE92,PSGOER
                PSGOER0,PSJRXLAB
   DTOUT        PSGOEV~,PSJRXLAB~
   DUOUT        PSGOER~,PSGOER0,PSGOEV~,PSJRXLAB~
   DUR          PSGOE81*~,PSGOER0*!,PSGOEV*~
   DURMIN       PSGOE81*~,PSGOER0*!
   DURON        PSGOEV*~
   DUZ          PSGOER,PSGOER0,PSGOEV
   EXPDT        PSGOER~
   F            PSGOE41!,PSGOE42!,PSGOE8!,PSGOE82!,PSGOE92!,PSGOER0!,PSGOEV!
   F0           PSGOE41!,PSGOE42!,PSGOE8!,PSGOE82!,PSGOE92!,PSGOER0!
   F1           PSGOE41!,PSGOE42!,PSGOER0*!
   F2           PSGOE8*!
   F3           PSGOE41!,PSGOE42!,PSGOE82!,PSGOE92!,PSGOER0!
>> FB           PSGOE41*,PSGOE42,PSGOE81*
   FDSD         PSGOER!
   FFF          PSJRXLAB*~
>> FILE         PSGOER*
   FILE55       PSGOEV*~
   FILE55N0     PSGOEV*~
   FLAG         PSJOE!
   FLIM         PSJRXLAB*~
   FQC          PSJOE!
   FREQ         PSGOER*~
   FSIG         PSJRXLAB!
   FSIG(        PSJRXLAB*
   FSIG(1       PSJRXLAB*
   FSIG(2       PSJRXLAB!
   FVAR         PSJRXLAB*~
   FVAR1        PSJRXLAB*~
   H            PSGOE41*~,PSGOE81*~
   HSIG         PSJRXLAB~
   HSIG(        PSJRXLAB*
   HSIG(0       PSJRXLAB
   I            PSGOE41*~,PSGOE81*~
   II           PSJRXLAB*~
   III          PSJRXLAB*~
   INFO         PSGOE41*~,PSGOE81*~
   INTERVAL     PSGOER*~
   INTERVEN     PSGOE82*~,PSGOER*~
   IO           PSJCLOLS,PSJRXLAB
   IO("Q"       PSJCLOLS,PSJRXLAB!
>> IOBM         PSJOE*
   IOF          PSGOE7,PSJCLOLS,PSJCLOZ,PSJRXLAB
   IOM          PSGOE7,PSJRXLAB
   IOP          PSJRXLAB!
>> IORC         PSJOE
>> IOS          PSJOE
>> IOSC         PSJOE
   IOSL         PSJCLOLS,PSJOE,PSJRXLAB
   IOST         PSGOER,PSJCLOLS,PSJRXLAB
>> IOSTBM       PSJOE
>> IOTM         PSJOE*
   IVSTYP       PSGOER*~
   J            PSJCLOLS*!,PSJRXLAB*!
   J1           PSJRXLAB!
   J2           PSJRXLAB*!
   LAST         PSGOER*~
   LASTAT       PSGOER~
   LDATE        PSJRXLAB*!
   LDATER       PSJRXLAB*!
   LIMIT        PSGOER*~
   LIST         PSGOEV*~
   LRDFN        PSJRXLAB*!
   LSTSTR       PSGOER*~
   LYN          PSGOER!
   MAX          PSGOE41*~,PSGOE81*~
   MI           PSJOE!
   MSG          PSGOE8*,PSGOE81*~,PSGOE82*,PSGOE92*
   MSG(1        PSGOE81*
   MSG(2        PSGOE81*
   N            PSJOE!
   ND           PSGOER0,PSGOEV!~
   ND0          PSGOER*~
>> ND14         PSGOER*
   ND2          PSGOER*~,PSGOER0*!,PSGOEV~,PSJOE!
   NDP2         PSJOE*~
   NE           PSJOE!
   NNN          PSJRXLAB*~
   NODE0        PSJOE*~
   NOW          PSGOER*~
   NXTADM       PSGOER*~
   NXTPT        PSJOE*~
   OEORD        PSGOEV*~
   ON           PSGOE92,PSJOE*!~
   ON55         PSJOE~
   OOEORD       PSGOEV*~
>> ORCLOZ       PSJCLOZ
   ORCLPAT      PSJCLOZ*~
   ORIFN        PSJOE*~
   ORIG         PSGOE81*!
   ORMAX        PSJCLOZ*~
>> ORO          PSJCLOZ
>> ORX          PSJCLOZ
   ORY          PSJCLOZ*!
>> ORYS         PSJCLOZ
   P            PSGOER~
   P(           PSGOER*
   P("PON"      PSJOE*
   P(11         PSGOER
   P(17         PSJOE
   P(2          PSGOER
   P(3          PSJOE
   P(4          PSGOER
   P(9          PSGOER
   P2ND         PSGOE92*~
   P3           PSJOE!
   PAGE         PSJRXLAB*!
   PARENT       PSGOE92*~
   PDRG         PSGOE7~
   PKF          PSGOE7~
   PKGFLG       PSGOER0*~
   PND0         PSGOEV*~
   PNDON        PSGOE8~
   PNOW         PSJOE!
   POP          PSJCLOLS!,PSJRXLAB!
   PRI          PSJOE!
   PROMPT       PSJOE~
   PROV         PSJCLOZ~
   PS538        PSJCLOZ*~
   PSBCNT       PSGOER~
   PSBDT        PSGOER!
   PSBFLAG      PSGOER!
   PSBSTR       PSGOER!
>> PSCDATE      PSJCLOZ*
>> PSCLPAT      PSJCLOZ
   PSCNT        PSJRXLAB*~
   PSG          PSGOE41!,PSGOE42!,PSGOE82!,PSGOE92!
>> PSGACT       PSGOEV*,PSJOE*
   PSGAL        PSGOER!,PSGOEV!
   PSGAL("C"    PSGOER*,PSGOEV*
   PSGAL531     PSGOEV*~
   PSGALFN      PSGOEV!
   PSGALR       PSGOER!
   PSGAT        PSGOE41*,PSGOE8*,PSGOE81*,PSGOER~,PSGOEV
   PSGCANFL     PSGOER*,PSGOEV*,PSJOE!
   PSGCF        PSJOE!
   PSGCFLG      PSGOE41*!,PSGOE81*!
   PSGCOPY      PSGOEV,PSJOE*!
   PSGDDI       PSGOER*,PSGOEV*~
   PSGDFLG      PSGOEV*!
   PSGDGCKF     PSGOE7*~
>> PSGDI        PSGOEV*
   PSGDICS      PSGOE7*!
   PSGDL        PSGOE41*,PSGOE81*,PSGOER!,PSGOER0*!
   PSGDLS       PSGOE41!,PSGOE81!,PSGOER!,PSGOER0!
   PSGDN        PSGOEV*~,PSJOE
>> PSGDO        PSGOE7*,PSGOE8*
   PSGDRG       PSGOE41,PSGOE42*,PSGOE7*,PSGOE81,PSGOE82*,PSGOER*~,PSJOE*!
>> PSGDRGN      PSGOE7*
   PSGDRGTMP    PSGOE8*!
   PSGDT        PSGOE41,PSGOE81,PSGOER*~,PSGOER0*~,PSGOEV
   PSGDW        PSGOER~
>> PSGEFN(8     PSGOE8
   PSGF2        PSGOE41*!,PSGOE42*!,PSGOE81*,PSGOE82*!,PSGOE92*!,PSGOER0*!
   PSGFD        PSGOE41*,PSGOE81*,PSGOER!,PSGOER0*
>> PSGFDN       PSGOE81*,PSGOER0*
   PSGFDNOLD    PSGOE81*!
   PSGFDX       PSGOE81*!,PSJOE~
   PSGFLG       PSGOE41,PSGOE7*~
   PSGFOK       PSGOER!,PSGOER0!
   PSGFOK(1     PSGOE42*,PSGOER0*
   PSGFOK(10    PSGOE41*,PSGOER0*
   PSGFOK(106   PSGOER,PSGOER0*
   PSGFOK(13    PSGOE42
   PSGFOK(25    PSGOE41*,PSGOER0*
   PSGFOK(39    PSGOE41*
   PSGFOK(5     PSGOE42*
   PSGFOK(8     PSGOE41*
   PSGGCNID     PSGOE7*~
   PSGGCNPT     PSGOE7*~
>> PSGHSM       PSGOE42*,PSGOE82*,PSGOE92*
   PSGIENID     PSGOE7~
>> PSGLI        PSGOE81,PSGOER0
   PSGLMT       PSJOE*~
>> PSGMR        PSGOE8*
>> PSGMRN       PSGOE8*
   PSGND1       PSGOE82~
   PSGND3       PSGOE82~
   PSGND4       PSGOER*!
   PSGNDFID     PSGOE7*~
   PSGNEDFD     PSGOE41,PSGOE7*,PSGOE8*,PSGOER0*!,PSJOE*!
   PSGNEF       PSJOE*!
   PSGNEFD      PSGOE41*,PSGOE81*,PSGOER0~,PSJOE!
>> PSGNEFDO     PSGOE41
   PSGNEFDOLD   PSGOE41*,PSGOE81*!
   PSGNEPR      PSJOE!
   PSGNESD      PSGOE41*,PSGOE81*,PSGOER*,PSGOER0*~,PSJOE!
>> PSGNESDO     PSGOE41*
>> PSGOAT       PSGOE8*,PSGOE81*
   PSGOC        PSGOER~
   PSGODA       PSGOEV!
   PSGODDD      PSJOE~
   PSGODDD(     PSJOE
   PSGODDD(0    PSJOE
   PSGODDD(1    PSGOER0,PSGOEV
   PSGODO       PSGOE7!
   PSGOE        PSJOE!
>> PSGOE3       PSGOE41
   PSGOEA       PSJOE!
   PSGOEAV      PSGOER*~,PSGOEV*,PSJOE*!
   PSGOEDMR     PSJOE!
   PSGOEE       PSGOE8*,PSGOE81*,PSGOE82*,PSGOE92*,PSGOER*!
>> PSGOEEF      PSGOE82,PSGOE92,PSJOE*
>> PSGOEEF(     PSGOE8*,PSGOE81,PSGOE82,PSGOE92
>> PSGOEEF(109  PSGOE82*,PSGOE92*,PSGOEV*
>> PSGOEEF(39   PSGOE8*
>> PSGOEEF(6    PSGOE82*!,PSGOE92*!
>> PSGOEEF(7    PSGOE8*
   PSGOEEND     PSGOE82!,PSGOE92*!
>> PSGOEENO     PSGOER*
   PSGOENG      PSJOE*!
>> PSGOEORD     PSGOER*
   PSGOEORF     PSJOE!
   PSGOEOS      PSGOER!
   PSGOEPR      PSGOER~,PSGOER0*!,PSJOE!
   PSGOER0      PSGOER!,PSGOER0*!
   PSGOER1      PSGOER!
   PSGOER2      PSGOER!,PSGOER0*!
   PSGOERDP     PSGOER!,PSGOER0*!
   PSGOES       PSGOE8~,PSGOER~,PSGOEV*~,PSJOE
   PSGOFD       PSGOER~,PSGOER0*!
   PSGOL        PSJOE!
   PSGOLDED     PSGOE41*,PSGOE81*!
   PSGON        PSJOE!
>> PSGONC       PSJOE*
>> PSGONF       PSGOER0,PSGOEV
>> PSGOOPD      PSGOE8*
>> PSGOOPDN     PSGOE8*
   PSGOORD      PSGOER*~
   PSGOP        PSJOE*!
   PSGOPR       PSGOER,PSGOER0*!
   PSGORD       PSGOE41,PSGOE7!,PSGOE8,PSGOE81,PSGOE82,PSGOE92,PSGOER*~,PSGOER~
                PSGOER0~,PSGOEV*~,PSGOEV~,PSJOE*!~
   PSGORDP      PSGOEV*~
   PSGORDR      PSGOEV*~
   PSGOREAS     PSGOER~
   PSGOROE1     PSGOE41*,PSGOE42*,PSGOER0!
   PSGORQF      PSGOE7*,PSGOE82~,PSGOER*!,PSGOER0,PSGOEV~
   PSGOS        PSJOE!
   PSGOSD       PSGOER0*!
>> PSGOST       PSGOE8*
   PSGP         PSGOE41*~,PSGOE7,PSGOE81*~,PSGOE82,PSGOE92,PSGOER~,PSGOER
                PSGOER0~,PSGOEV,PSJOE*~,PSJOE~
   PSGPD        PSGOE8*,PSGOEV*!,PSJOE*
>> PSGPDN       PSGOE8*,PSJOE*
   PSGPDNOLD    PSGOE8*!
>> PSGPDNX      PSGOE8*
   PSGPDOLD     PSGOE8*!
   PSGPDRG      PSGOE42,PSGOE7*,PSGOE8*,PSGOE82,PSGOER0*!
>> PSGPDRGN     PSGOE7*,PSGOE8*
   PSGPDRGOLD   PSGOE8*!
   PSGPFLG      PSGOEV*!
   PSGPOI       PSGOER*~
   PSGPOSA      PSGOER*!
   PSGPOSD      PSGOER*!
   PSGPR        PSGOE42*,PSGOE82*,PSGOE92*,PSGOER*!~,PSGOER0*,PSJCLOZ
>> PSGPRF       PSJOE
   PSGPRI       PSGOER0*!,PSJOE!
   PSGPRN       PSGOE42*,PSGOE82*,PSGOE92*,PSGOER0*!
>> PSGPTMP      PSJOE*
   PSGPTS       PSJOE!
   PSGPX        PSGOER!
>> PSGPXN       PSJOE*
   PSGPXPT      PSJOE*!
   PSGRD        PSGOER!
   PSGRDTX      PSGOEV*,PSJOE!~
>> PSGRENEW     PSGOER0
   PSGRFD       PSGOEV!,PSJOE~
   PSGRFDN      PSJOE~
   PSGRFOUR     PSGOER*~
   PSGRNSD      PSGOER0*!
   PSGRO        PSGOER0*!
>> PSGRRF       PSJOE
   PSGRSD       PSGOEV!,PSJOE~
   PSGRSDN      PSJOE~
   PSGRZERO     PSGOER*~
   PSGS0XT      PSGOE41,PSGOE81,PSGOER*~,PSGOER0*!,PSGOEV*~,PSJOE!
   PSGS0Y       PSGOE41*,PSGOE8,PSGOE81*,PSGOER~,PSGOER0*!,PSGOEV~,PSJOE!
   PSGSCH       PSGOE41,PSGOE8*,PSGOE81,PSGOER,PSGOER0*!,PSGOEV,PSJOE
   PSGSD        PSGOE41*,PSGOE81*,PSGOER!,PSGOER0*~
   PSGSDN       PSGOE81*,PSGOER0*!,PSJOE!
   PSGSDX       PSGOE81*!,PSJOE~
   PSGSFLG      PSGOE8*~
>> PSGSI        PSGOE41*,PSGOE81*
>> PSGSM        PSGOE42*,PSGOE82*,PSGOE92*
   PSGST        PSGOE41,PSGOE8*,PSGOE81,PSGOER~,PSGOER0*!,PSGOEV
>> PSGSTAT      PSJOE
>> PSGSTN       PSGOE8*
   PSGTMPXN     PSJOE*~
   PSGTOL       PSGOER!,PSGOEV*!,PSJOE!
   PSGTOO       PSGOER!,PSGOEV*!,PSJOE!
>> PSGUD        PSGOE42
   PSGUOW       PSGOER!,PSGOEV*!,PSJOE!
   PSGUSRX      PSGOE7*!
   PSGVBY       PSJOE!
   PSGWLL       PSGOER*!,PSGOER0*!
   PSGX         PSGOE7*,PSGOE82*~,PSGOE92*~,PSGOEV*~
   PSGXDA       PSGOEV*~
   PSGXX        PSGOE82*~,PSGOE92*!~
   PSGY         PSGOE82*~
   PSIVAT       PSJOE!
>> PSIVCOPY     PSJOE
   PSIVENO      PSJOE!~
   PSIVFLG      PSJOE*!
   PSIVLN       PSJOE!
   PSIVREA      PSJOE!
   PSIVSTR      PSJOE!
   PSJ          PSJRXLAB*~
>> PSJ1PH       PSJCLOZ*
   PSJ2         PSJRXLAB*~
>> PSJ2PH       PSJCLOZ*
   PSJABT       PSGOER~
>> PSJACEPT     PSGOEV*
   PSJACNWP     PSJOE~
   PSJACOK      PSJOE*!
   PSJACPF      PSJOE*~
   PSJAGYSV     PSGOEV!,PSJOE*!~
>> PSJALGY1     PSGOE82
   PSJALLGY     PSGOE7!~,PSGOE82~,PSGOER~,PSGOEV~
   PSJALLGY(    PSGOE7*,PSGOE82*,PSGOER*,PSGOEV*
   PSJALLGY(0   PSGOER
   PSJANS       PSJRXLAB*!
   PSJAPR       PSJCLOLS*!
   PSJBD        PSJRXLAB*!
   PSJBDR       PSJRXLAB*!
   PSJBINTR     PSJRXLAB~
   PSJBLGTH     PSJRXLAB~
>> PSJCLPAT     PSJCLOZ*
   PSJCNT       PSGOEV*~
   PSJCNT1      PSGOEV*~
   PSJCNT2      PSGOEV*~
>> PSJCOI       PSJOE
   PSJCOM       PSGOER,PSGOEV*,PSJCLOLS*!,PSJOE
   PSJCT        PSJOE!
   PSJDATA      PSJCLOLS*!
   PSJDD        PSGOE82*~,PSGOER*~,PSGOEV*~
   PSJDD0       PSGOER*~
   PSJDD55      PSGOE92*!
   PSJDD55(     PSGOE92*
   PSJDD551     PSGOE92*!
   PSJDDI       PSGOE82~,PSGOER~
   PSJDDTMP     PSGOE92*!
   PSJDDTMP(    PSGOE92*
>> PSJDGCK      PSGOE7
   PSJDGN       PSJRXLAB*!
   PSJDIS       PSGOEV*~
   PSJDOSE      PSGOE7!,PSGOE82~,PSGOE92~,PSGOEV!~
   PSJDOSE("WARN" 
                PSGOEV
   PSJDOSE("WARN1" 
                PSGOEV
   PSJDOX       PSGOE7!
   PSJDRG       PSJCLOLS*!
   PSJDRUG      PSJRXLAB*!
   PSJDRUGN     PSJRXLAB*!
   PSJDSFLG     PSGOE82,PSGOE92,PSGOEV~
   PSJDSVFY     PSGOEV,PSJOE~
   PSJDTMP1     PSGOE92*!
   PSJED        PSJRXLAB*!
   PSJEDITO     PSJOE*~
   PSJEDR       PSJRXLAB*!
   PSJENHOC     PSJOE~
   PSJEXCPT     PSJOE!
   PSJEXPIR     PSGOER*~
   PSJEXPOE     PSGOER*!
   PSJFILE      PSJRXLAB~
   PSJFLG       PSGOEV*~
>> PSJHLDFN     PSGOEV
   PSJINACT     PSGOE8*~
   PSJINDIC     PSJRXLAB*!
   PSJINTR      PSJRXLAB~
   PSJIREQ      PSGOE82*~,PSGOER*~
   PSJIVFLG     PSJOE*~
   PSJIVOF      PSJOE!
   PSJIVORF     PSJOE!
   PSJIVPCL     PSJOE!
   PSJLABQ      PSJRXLAB*!
   PSJLABT      PSJRXLAB*!
   PSJLABTN     PSJRXLAB*!
   PSJLBENT     PSJRXLAB*!
   PSJLBT       PSJRXLAB*!
   PSJLDATE     PSJRXLAB*!
   PSJLENTH     PSJRXLAB~
   PSJLK        PSJOE*~
   PSJLM        PSJOE*!~
   PSJLMCON     PSJOE*~
   PSJLMFIN     PSGOEV,PSJOE~
   PSJLMPRO     PSJOE*!
   PSJLMQT      PSJOE~
   PSJLUAPP     PSGOE7!
   PSJLYN       PSJOE*!
   PSJMAI       PSJOE!
   PSJNEWOE     PSGOE8,PSGOEV,PSJOE*~
   PSJNOL       PSJOE!
   PSJNOO       PSGOER*~,PSGOER0*!
   PSJNSS       PSGOER~
   PSJNUM       PSJCLOLS*,PSJRXLAB*~
   PSJOCDSC     PSJOE!~
   PSJOCER      PSJOE!
   PSJOCFG      PSGOER0,PSJOE*!~
   PSJOCNT      PSGOE7,PSJOE!
   PSJOD        PSJCLOLS*!
   PSJOE        PSJOE!
   PSJOECNT     PSJOE!
   PSJOEPF      PSJOE!
>> PSJOL        PSJOE*
   PSJON        PSJOE!
   PSJOPC       PSJOE!
   PSJORD       PSGOE7!,PSGOE92,PSGOER,PSGOEV,PSJCLOLS*,PSJOE*!~,PSJOE*~
   PSJORDER     PSGOER*~
   PSJORDER("PSJORN" 
                PSJCLOZ*
   PSJORDN      PSJRXLAB*!
   PSJORL       PSJOE!
>> PSJORN       PSJCLOZ*
   PSJORPCL     PSJOE!
   PSJORQF      PSGOE7*,PSJOE!
   PSJORTOI     PSJOE!
   PSJORTOU     PSJOE!
   PSJORVP      PSJOE!
   PSJPAT       PSJCLOLS*!
>> PSJPDD       PSJOE
   PSJPDRG      PSGOE82~,PSGOER~
   PSJPDXP      PSJOE*!
   PSJPNDRN     PSGOE82*~
   PSJPNV       PSJOE~
   PSJPR        PSJOE!
>> PSJPRI       PSGOEV
   PSJPRIO      PSGOEV*~
   PSJPROT      PSJOE*~,PSJRXLAB*!
   PSJPROV      PSJCLOZ*,PSJRXLAB*!
   PSJPROVN     PSJRXLAB*!
   PSJPSTO      PSGOER~
   PSJPT        PSJRXLAB*!
   PSJPWD       PSGOER~,PSJOE*~
   PSJPXDP      PSJOE~
   PSJQUIT      PSJCLOZ*~
   PSJRBCNT     PSGOE8*~
   PSJREA       PSJCLOLS*!
>> PSJREASN     PSJCLOZ*
>> PSJREMRK     PSJCLOZ*
   PSJREN       PSGOER*~,PSGOER0*!
   PSJRSB       PSGOE8*~
   PSJRX        PSJCLOLS!
   PSJRXREQ     PSGOE82*~,PSGOER*~
   PSJSCHED     PSGOEV*~
>> PSJSEL       PSJOE*
>> PSJSEL1      PSJOE*
   PSJSLUP      PSGOE8*~
   PSJSP        PSJRXLAB*!
>> PSJSPEED     PSGOER,PSGOER0,PSGOEV
   PSJSTARI     PSGOEV,PSJOE!
   PSJSYSL      PSGOEV,PSJOE~
>> PSJSYSO      PSGOER
   PSJSYSP      PSGOE41,PSGOE42,PSGOE7,PSGOE8~,PSGOE81,PSGOE82,PSGOE92,PSGOER
                PSGOER0,PSGOEV,PSJOE
>> PSJSYSP0     PSGOER,PSGOER0,PSGOEV,PSJOE
>> PSJSYSU      PSGOE42,PSGOE7,PSGOE8,PSGOE82,PSGOE92,PSGOER,PSGOER0,PSGOEV
                PSJOE
   PSJSYSW      PSJOE~
   PSJSYSW0     PSGOE41,PSGOE42,PSGOE8,PSGOER,PSGOER0,PSJOE*~
>> PSJTUD       PSJOE
   PSJTYPE      PSJRXLAB*!
   PSJUDPRF     PSJOE~
   PSJUNIT      PSJRXLAB*!
   PSJUSR       PSJCLOLS*!
   PSJVAR       PSGOEV!
   PSJX         PSGOER*~,PSGOEV*~
   PSJXX1       PSJOE*~
   PSJY         PSGOER~
   PSJYSCL      PSJOE*~
   PSOBD        PSJCLOLS*!
   PSOED        PSJCLOLS*!
   PSOI         PSJCLOLS*!
>> PSOLAST4     PSJCLOZ*
   PSREV        PSJRXLAB*!
   PSTMPI       PSGOE42*!,PSGOE82*!,PSGOE92*!,PSGOER0*!
   PSTMPN       PSGOE42*!,PSGOE82*!,PSGOE92*!,PSGOER0*!
   Q            PSGOE7*~,PSGOER*,PSGOEV*~
   Q1           PSGOE7*!
   Q2           PSGOE7!
   Q3           PSGOE7*!
>> QOAA         PSJCLOZ
   QODS         PSJCLOZ*~
>> QOIEN        PSJCLOZ
   QORF         PSJCLOZ*~
   QQ           PSGOEV*~
   QX           PSGOER~,PSGOEV~
   RCT          PSJOE!
   RDATE        PSGOER~
   RDUZ         PSGOER~
   RF           PSGOER!,PSJOE!
   RNWDT        PSGOER~
>> RNWL         PSGOE8*
   RTN          PSGOE7*~,PSJCLOZ*~
   SCH          PSGOE8~
   SCHED        PSGOER*~
   SD           PSGOER~
   SDT          PSGOE41!,PSGOE42!,PSGOE82!,PSGOE92!,PSGOER0!
   SDW          PSGOER~,PSGOEV~
   SITE         PSJRXLAB*!
   ST           PSGOER~,PSJOE!
   STATUS       PSGOER*~
   STOP         PSGOER*~
   SWD          PSGOER~,PSGOEV~
   TEST         PSGOER~
>> TIUDA        PSGOEV
   TMPFD        PSGOE81*!~
   TMPX         PSGOE41*~,PSGOE81*~
   TXTLN        PSGOEV*~
   U            PSGOE41,PSGOE7,PSGOE8,PSGOE81,PSGOER*~,PSGOER0,PSGOEV,PSJCLOZ
                PSJOE
>> VA("PID"     PSJRXLAB
   VAERR        PSJOE~
   VAIN         PSJOE~
   VAIN(4       PSJOE
   VAIP         PSJOE~
>> VALM("TM"    PSJOE
   VALMBCK      PSGOER*~,PSGOEV*,PSJOE*
   VALMEVL      PSJOE~
>> VALMQUIT     PSJOE*
   VND4         PSGOEV*!
   WD           PSGOER~,PSJOE!
   WSCHADM      PSJOE!
   X            PSGOE41*!~,PSGOE41~,PSGOE42*,PSGOE7*~,PSGOE8*,PSGOE8*~
                PSGOE81*!~,PSGOE81~,PSGOE82*,PSGOE92*~,PSGOER*~,PSGOER0*!
                PSGOEV*!~,PSJCLOLS*!,PSJCLOZ*!,PSJOE*,|dd53.8*!
   X1           PSGOE41*~,PSGOE81*~
   X2           PSGOE41*~,PSGOE81*~
   X3           PSGOE41*~
   XABB         PSGOER~,PSGOEV~
>> XMY          PSJCLOZ
   XP           PSGOER*~
>> XQA          PSJCLOZ*
>> XQA(         PSJCLOZ*
>> XQAARCH      PSJCLOZ*
>> XQADATA      PSJCLOZ*
>> XQAFLG       PSJCLOZ*
>> XQAID        PSJCLOZ*
>> XQAMSG       PSJCLOZ*
>> XQORNOD(0    PSJOE
   XQORS        PSJOE~
   XQUIT        PSJOE!
   XREF         PSJOE!
   XX           PSGOE8*~,PSGOER0*~
   Y            PSGOE41*!,PSGOE42*,PSGOE7*,PSGOE8,PSGOE81*,PSGOE82*,PSGOE92*~
                PSGOER*~,PSGOER0*!,PSGOEV*!~,PSJCLOLS,PSJCLOZ*!~,PSJOE
                PSJRXLAB*!,|dd53.8
   Y(0          PSGOE42,PSGOE7*,PSGOE8,PSGOE82,PSGOE92,PSGOER0
   YP           PSGOER*~
>> YSCLR        PSJOE
   Z            PSGOE41*~,PSGOE7*!,PSGOE81*~,PSJOE!
   ZTDESC       PSJCLOLS*!,PSJRXLAB*!
   ZTIO         PSJCLOLS!
>> ZTQUEUED     PSJRXLAB
>> ZTREQ        PSJRXLAB*
   ZTRTN        PSJCLOLS*!,PSJRXLAB*!
   ZTSAVE       PSJCLOLS!,PSJRXLAB!
   ZTSAVE("*"   PSJRXLAB*
   ZTSAVE("PSOBD" 
                PSJCLOLS*
   ZTSAVE("PSOED" 
                PSJCLOLS*
   ZTSK         PSJCLOLS!,PSJRXLAB!
   ZZND         PSGOER~,PSGOEV!

Global Variables
   ^DD("DD"            PSJRXLAB
   ^DPT(               PSJCLOLS,PSJCLOZ,PSJOE,PSJRXLAB
   ^LAB(60             PSJRXLAB
   ^LR(                PSJRXLAB
   ^OR(100             PSJCLOLS,PSJRXLAB
   ^ORD(101            PSGOEV
   ^ORD(101.41         PSJCLOZ
   ^PS(50.3            PSGOE7
   ^PS(50.7            PSGOE7,PSGOE8,PSGOEV
   ^PS(51.1            PSGOE41,PSGOE8,PSGOE81,PSGOER
   ^PS(51.2            PSGOE8
   ^PS(52.41           PSJRXLAB
   ^PS(52.54           PSJCLOLS
   ^PS(53              PSJCLOZ
   ^PS(53.1            PSGOE82,PSGOE92,PSGOEV,PSJOE
   ^PS(53.45           PSGOE41,PSGOE42,PSGOE7!,PSGOE8*!,PSGOE81,PSGOE82!
                       PSGOE92,PSGOER*!,PSGOER0!,PSGOEV*!,PSJOE
   ^PS(53.8            PSJCLOLS,|dd53.8*!
   ^PS(55              PSGOE92,PSGOER*,PSGOER0,PSGOEV*!,PSJOE
   ^PS(59.7            PSGOE7,PSGOER
   ^PSDRUG(            PSGOE7,PSGOE92,PSGOER,PSGOEV,PSJCLOLS,PSJCLOZ,PSJRXLAB
   ^PSDRUG("ACLOZ"     PSGOE42,PSGOE8,PSGOE82,PSGOER,PSJOE
   ^PSDRUG("ASP"       PSGOE42,PSGOE7,PSGOE8,PSGOE82,PSJOE
   ^PSDRUG("B"         PSJRXLAB
   ^TMP("CLOZFLG"      PSGOE41,PSGOE81
   ^TMP("ORDERNUM"     PSJRXLAB*!
   ^TMP("PSJ"          PSJOE!
   ^TMP("PSJCOM"       PSJOE!
   ^TMP("PSJCOM2"      PSJOE!
   ^TMP("PSJDAOC"      PSGOER!,PSJOE!
   ^TMP("PSJINTER"     PSGOE7!
   ^TMP("PSJON"        PSJOE!
   ^TMP("PSJPRO"       PSJOE!
   ^TMP("PSODAOC"      PSGOE7!,PSGOER*!,PSGOEV*,PSJOE*!
   ^TMP($J             PSGOEV!,PSJOE!
   ^UTILITY("DIQ1"     PSJRXLAB!
   ^VA(200             PSGOE42,PSGOE82,PSGOE92,PSGOER0,PSJCLOLS,PSJRXLAB
   ^XUSEC("PSOLOCKCLOZ"PSJCLOZ
   ^XUSEC("YSCL AUTHORIZED"
                       PSJCLOZ

Naked Globals
   ^(           PSGOE42,PSGOE7,PSGOE8,PSGOE82,PSGOER,PSGOER0,PSGOEV,PSJCLOLS
                PSJOE,PSJRXLAB
   ^("I"        PSGOE7,PSGOER,PSGOEV
   ^("PS"       PSGOE42,PSGOE82,PSGOE92,PSGOER0
   ^("SIG"      PSJRXLAB
   ^(0          PSGOE8,PSGOEV*,PSJCLOLS,PSJRXLAB
   ^(1          PSGOE42*,PSGOE8*
   ^(2          PSGOE42*,PSGOE7,PSGOER!,PSGOER0!,PSGOEV
   ^(4          PSGOEV,PSJOE
   ^(7          PSGOEV*

Cache Objects
   NONE

Marked Items
   $T(@(3)      PSGOE82,PSGOE92

Routine             Invokes:
   PSGOE41      %DT,%DTC,C^%DTC,YN^DICN,$$ENDL^PSGDL,EN1^PSGDL,ENPREV^PSGDL
                $$ENDD^PSGMI,PSGNE3,ENFD^PSGNE3,1^PSGOE42,ENFF^PSGOEM
                ENHLP^PSGOEM,$$ODD^PSGS0,ENCHK^PSGS0,$$EDITSI^PSJBCMA5
                $$ENOSD^PSJDCU,$$ENQ^PSJORP2,$$ENBCMA^PSJUTL,EFDNEW^PSJUTL
   PSGOE42      DIC,YN^DICN,DIE,ENFF^PSGOEM,ENHLP^PSGOEM,PROVCHK^PSJCLOZ
   PSGOE7       @(,DIC,MIX^DIC1,YN^DICN,DIR,$$ENDDN^PSGMI,ENDDC^PSGSICHK
                KILL^PSJBCMA5,$$DGCKIEN^PSJDGCK,$$PSJSUPCK^PSJDGCK,DIN^PSJDIN
                $$OINAME^PSJLMUTL,READ^PSJUTL,$$PROD0^PSNAPIS
   PSGOE8       DIC,MIX^DIC1,YN^DICN,$$ENLU^PSGMI,$$ENSTN^PSGMI
                $$GTNEDFD^PSGOE7,ENFF^PSGOE82,ENDRG^PSGOEF1,ENHLP^PSGOEM
                $$PRNOK^PSGS0,EN^PSGS0,$$DOW^PSIVUTL,CLOZ^PSJCLOZ
                EDITDOSE^PSJDOSE,$$OINAME^PSJLMUTL,PAUSE^VALM1
   PSGOE81      %DT,%DTC,C^%DTC,EN^DDIOL,YN^DICN,$$ENDL^PSGDL,ENE^PSGDL
                ENPREV^PSGDL,$$ENDD^PSGMI,$$ENDTC^PSGMI,ENFF^PSGOE82
                ENFF^PSGOEM,ENHLP^PSGOEM,$$ODD^PSGS0,$$PRNOK^PSGS0,ENCHK^PSGS0
                $$DIFFSI^PSJBCMA5,$$EDITSI^PSJBCMA5,$$DURMIN^PSJLIVMD
                $$GETDUR^PSJLIVMD
                $$LASTREN^PSJLMPRI,$$ENQ^PSJORP2,$$ENBCMA^PSJUTL,EFDNV^PSJUTL
                PAUSE^VALM1,$$FMADD^XLFDT
   PSGOE82      DIC,YN^DICN,DIE,ENHLP^PSGOEM,$$CODES2^PSIVUTL,PROVCHK^PSJCLOZ
                DOSECHK^PSJDOSE,DSPWARN^PSJDOSE,$$LASTREN^PSJLMPRI
                ALLERGY^PSJOC,PAUSE^VALM1
   PSGOE92      DIC,YN^DICN,DIE,NEWUDAL^PSGAL5,CLOZPRV^PSGOE82,DDOC^PSGOE82
                ENHLP^PSGOEM,$$CODES2^PSIVUTL,CMPLX^PSJCOM1,DOSECHK^PSJDOSE
                DSPWARN^PSJDOSE,$$COMPLEX^PSJOE,FULL^VALM1,PAUSE^VALM1
   PSGOER       NOW^%DTC,FILE^DICN,DIE,DIR,$$EN^PSBAPIPM,PSGAL5,ABORT^PSGOEE
                DATE^PSGOER0,EN^PSGPEN,$$PRNOK^PSGS0,DW^PSGS0,ENDDC^PSGSICHK
                ENPOS^PSGVDS,$$DOW^PSIVUTL,CLOZ^PSJCLOZ,PSJCOMR,EN1^PSJHL2
                $$SCHREQ^PSJLIVFD,PAUSE^PSJLMUT1,SETOC^PSJNEWOC,IN^PSJOCDS
                ENUDTX^PSJOREN,$$ENQ^PSJORP2,$$LASTAT^PSJORP2,ADMIN^PSJORPOE
                $$ACTIVE^PSJORREN,$$DATE^PSJUTL2,$$DATE2^PSJUTL2,$$LS^PSSLOCK
                UNL^PSSLOCK,PAUSE^VALM1,$$FMADD^XLFDT
   PSGOER0      %DT,DIC,$$ENDL^PSGDL,ENGO^PSGDL,$$ENDD^PSGMI,$$ENSD^PSGNE3
                ENFD^PSGNE3,ENWALL^PSGNE3,$$DDOK^PSGOE2,$$GTNEDFD^PSGOE7
                CLOZPRV^PSGOE82,ENDRG^PSGOEF1,ENHLP^PSGOEM,NEWOC55^PSGOER
                $$ENOSD^PSJDCU,$$DURMIN^PSJLIVMD,$$GETDUR^PSJLIVMD
                $$ACTIVE^PSJORREN
                EFDNEW^PSJUTL,$$DATE2^PSJUTL2,$$ENNOO^PSJUTL5,$$FMADD^XLFDT
                $$NOW^XLFDT
   PSGOEV       %XY^%RCR,DIE,DIR,PSGAL5,NEWUDAL^PSGAL5,$$DDOK^PSGOE2
                $$OIOK^PSGOE2,$$CHECK^PSGOE8,ENDRG^PSGOEF1,EXPOE^PSGOER
                ORSET^PSGOETO1,PSGOT,START^PSGOTR,EN^PSGPEN,DW^PSGS0,ENOS^PSGS0
                ENDDC^PSGSICHK,ENL^PSGVDS,NEWJ^PSJADM,PROFILE^PSJBLDOC
                VFY^PSJCOM
                DOSECHK^PSJDOSE,SETVAR^PSJDOSE,EN1^PSJHL2,NOTIFY^PSJHL4
                $$GETDUR^PSJLIVMD,REQDT^PSJLIVMD,$$LASTREN^PSJLMPRI
                SETOC^PSJNEWOC,IN^PSJOCDS,CLOZSND^PSJOE,UNL^PSSLOCK
                MAIN^TIUEDIT,EN^VALM,FULL^VALM1,PAUSE^VALM1
   PSJCLOLS     %DT,%ZIS,%ZISC,%ZTLOAD
   PSJCLOZ      DD^%DT,NOW^%DTC,@(,FILE^DICN,DIE,$$GET1^DIQ,DIR,PHGRP^PSOCLO1
                SETUP^XQALERT,$$DEA^XUSER
   PSJOE        HOME^%ZIS,DIR,EN1^ORCFLAG,ENQL^PSGLW,PSGOD,$$ENACTION^PSGOE1
                H^PSGOE1,ENO^PSGOEC,ABORT^PSGOEE,ACT^PSGOEE,ENF^PSGOEE
                ENSFE^PSGOEE0,FINISH^PSGOEF,START^PSGOEF,ENLM^PSGOEL,PSGOER
                PSGOERI,ORSET^PSGOETO1,ENASR^PSGON,ENCHK^PSGON,PSGPER,PSGPER1
                ENCV^PSGSETU,ENIVKV^PSGSETU,COPY^PSIVOD,H^PSIVOPT,VF^PSIVORC2
                PSIVXU,PSJAC,ENIV^PSJAC,WP^PSJAC,CLOZ^PSJCLOZ,PSJFILE^PSJCLOZ
                PSJHVARS,RESTORE^PSJHVARS,EN^PSJLIFN,EN^PSJLIORD,REQDT^PSJLIVMD
                GETUD^PSJLMGUD,INIT^PSJLMUDE,$$HIDDEN^PSJLMUTL
                $$OINAME^PSJLMUTL,SETOC^PSJNEWOC,DONE^PSJOE,LOCKERR^PSJOE
                OLDCOM^PSJOE0,SELECT^PSJOEA,PSJP,$$L^PSSLOCK,$$LS^PSSLOCK
                UL^PSSLOCK,UNL^PSSLOCK,$$SDIMO^SDAMA203,INP^VADPT,EN^VALM
                FULL^VALM1,PAUSE^VALM1,$$PATCH^XPDUTL,INPSND^YSCLTST5
   PSJRXLAB     %DT,%ZIS,%ZISC,%ZTLOAD,DIC,EN^DIQ1,DIR,PID^VADPT,$$SITE^VASITE
   |dd53.8      %DT
   |opt         PSGSET,ENKV^PSGSETU,PSJCLOLS,PSJRXLAB

Routine             is Invoked by:
   ^%DT                PSGOE41,PSGOE81,PSGOER0,PSJCLOLS,PSJRXLAB,|dd53.8
   DD^%DT              PSJCLOZ
   ^%DTC               PSGOE41,PSGOE81
   C^%DTC              PSGOE41,PSGOE81
   NOW^%DTC            PSGOER,PSJCLOZ
   %XY^%RCR            PSGOEV
   ^%ZIS               PSJCLOLS,PSJRXLAB
   HOME^%ZIS           PSJOE
   ^%ZISC              PSJCLOLS,PSJRXLAB
   ^%ZTLOAD            PSJCLOLS,PSJRXLAB
   ^@(                 PSGOE7,PSJCLOZ
   EN^DDIOL            PSGOE81
   ^DIC                PSGOE42,PSGOE7,PSGOE8,PSGOE82,PSGOE92,PSGOER0,PSJRXLAB
   MIX^DIC1            PSGOE7,PSGOE8
   FILE^DICN           PSGOER,PSJCLOZ
   YN^DICN             PSGOE41,PSGOE42,PSGOE7,PSGOE8,PSGOE81,PSGOE82,PSGOE92
   ^DIE                PSGOE42,PSGOE82,PSGOE92,PSGOER,PSGOEV,PSJCLOZ
   $$GET1^DIQ          PSJCLOZ
   EN^DIQ1             PSJRXLAB
   ^DIR                PSGOE7,PSGOER,PSGOEV,PSJCLOZ,PSJOE,PSJRXLAB
   EN1^ORCFLAG         PSJOE
   $$EN^PSBAPIPM       PSGOER
   ^PSGAL5             PSGOER,PSGOEV
   NEWUDAL^PSGAL5      PSGOE92,PSGOEV
   $$ENDL^PSGDL        PSGOE41,PSGOE81,PSGOER0
   EN1^PSGDL           PSGOE41
   ENE^PSGDL           PSGOE81
   ENGO^PSGDL          PSGOER0
   ENPREV^PSGDL        PSGOE41,PSGOE81
   ENQL^PSGLW          PSJOE
   $$ENDD^PSGMI        PSGOE41,PSGOE81,PSGOER0
   $$ENDDN^PSGMI       PSGOE7
   $$ENDTC^PSGMI       PSGOE81
   $$ENLU^PSGMI        PSGOE8
   $$ENSTN^PSGMI       PSGOE8
   ^PSGNE3             PSGOE41
   $$ENSD^PSGNE3       PSGOER0
   ENFD^PSGNE3         PSGOE41,PSGOER0
   ENWALL^PSGNE3       PSGOER0
   ^PSGOD              PSJOE
   $$ENACTION^PSGOE1   PSJOE
   H^PSGOE1            PSJOE
   $$DDOK^PSGOE2       PSGOER0,PSGOEV
   $$OIOK^PSGOE2       PSGOEV
   1^PSGOE42           PSGOE41
   $$GTNEDFD^PSGOE7    PSGOE8,PSGOER0
   $$CHECK^PSGOE8      PSGOEV
   CLOZPRV^PSGOE82     PSGOE92,PSGOER0
   DDOC^PSGOE82        PSGOE92
   ENFF^PSGOE82        PSGOE8,PSGOE81
   ENO^PSGOEC          PSJOE
   ABORT^PSGOEE        PSGOER,PSJOE
   ACT^PSGOEE          PSJOE
   ENF^PSGOEE          PSJOE
   ENSFE^PSGOEE0       PSJOE
   FINISH^PSGOEF       PSJOE
   START^PSGOEF        PSJOE
   ENDRG^PSGOEF1       PSGOE8,PSGOER0,PSGOEV
   ENLM^PSGOEL         PSJOE
   ENFF^PSGOEM         PSGOE41,PSGOE42,PSGOE81
   ENHLP^PSGOEM        PSGOE41,PSGOE42,PSGOE8,PSGOE81,PSGOE82,PSGOE92,PSGOER0
   ^PSGOER             PSJOE
   EXPOE^PSGOER        PSGOEV
   NEWOC55^PSGOER      PSGOER0
   DATE^PSGOER0        PSGOER
   ^PSGOERI            PSJOE
   ORSET^PSGOETO1      PSGOEV,PSJOE
   ENASR^PSGON         PSJOE
   ENCHK^PSGON         PSJOE
   ^PSGOT              PSGOEV
   START^PSGOTR        PSGOEV
   EN^PSGPEN           PSGOER,PSGOEV
   ^PSGPER             PSJOE
   ^PSGPER1            PSJOE
   $$ODD^PSGS0         PSGOE41,PSGOE81
   $$PRNOK^PSGS0       PSGOE8,PSGOE81,PSGOER
   DW^PSGS0            PSGOER,PSGOEV
   EN^PSGS0            PSGOE8
   ENCHK^PSGS0         PSGOE41,PSGOE81
   ENOS^PSGS0          PSGOEV
   ^PSGSET             |opt
   ENCV^PSGSETU        PSJOE
   ENIVKV^PSGSETU      PSJOE
   ENKV^PSGSETU        |opt
   ENDDC^PSGSICHK      PSGOE7,PSGOER,PSGOEV
   ENL^PSGVDS          PSGOEV
   ENPOS^PSGVDS        PSGOER
   COPY^PSIVOD         PSJOE
   H^PSIVOPT           PSJOE
   VF^PSIVORC2         PSJOE
   $$CODES2^PSIVUTL    PSGOE82,PSGOE92
   $$DOW^PSIVUTL       PSGOE8,PSGOER
   ^PSIVXU             PSJOE
   ^PSJAC              PSJOE
   ENIV^PSJAC          PSJOE
   WP^PSJAC            PSJOE
   NEWJ^PSJADM         PSGOEV
   $$DIFFSI^PSJBCMA5   PSGOE81
   $$EDITSI^PSJBCMA5   PSGOE41,PSGOE81
   KILL^PSJBCMA5       PSGOE7
   PROFILE^PSJBLDOC    PSGOEV
   ^PSJCLOLS           |opt
   CLOZ^PSJCLOZ        PSGOE8,PSGOER,PSJOE
   PROVCHK^PSJCLOZ     PSGOE42,PSGOE82
   PSJFILE^PSJCLOZ     PSJOE
   VFY^PSJCOM          PSGOEV
   CMPLX^PSJCOM1       PSGOE92
   ^PSJCOMR            PSGOER
   $$ENOSD^PSJDCU      PSGOE41,PSGOER0
   $$DGCKIEN^PSJDGCK   PSGOE7
   $$PSJSUPCK^PSJDGCK  PSGOE7
   DIN^PSJDIN          PSGOE7
   DOSECHK^PSJDOSE     PSGOE82,PSGOE92,PSGOEV
   DSPWARN^PSJDOSE     PSGOE82,PSGOE92
   EDITDOSE^PSJDOSE    PSGOE8
   SETVAR^PSJDOSE      PSGOEV
   EN1^PSJHL2          PSGOER,PSGOEV
   NOTIFY^PSJHL4       PSGOEV
   ^PSJHVARS           PSJOE
   RESTORE^PSJHVARS    PSJOE
   EN^PSJLIFN          PSJOE
   EN^PSJLIORD         PSJOE
   $$SCHREQ^PSJLIVFD   PSGOER
   $$DURMIN^PSJLIVMD   PSGOE81,PSGOER0
   $$GETDUR^PSJLIVMD   PSGOE81,PSGOER0,PSGOEV
   REQDT^PSJLIVMD      PSGOEV,PSJOE
   GETUD^PSJLMGUD      PSJOE
   $$LASTREN^PSJLMPRI  PSGOE81,PSGOE82,PSGOEV
   INIT^PSJLMUDE       PSJOE
   PAUSE^PSJLMUT1      PSGOER
   $$HIDDEN^PSJLMUTL   PSJOE
   $$OINAME^PSJLMUTL   PSGOE7,PSGOE8,PSJOE
   SETOC^PSJNEWOC      PSGOER,PSGOEV,PSJOE
   ALLERGY^PSJOC       PSGOE82
   IN^PSJOCDS          PSGOER,PSGOEV
   $$COMPLEX^PSJOE     PSGOE92
   CLOZSND^PSJOE       PSGOEV
   DONE^PSJOE          PSJOE
   LOCKERR^PSJOE       PSJOE
   OLDCOM^PSJOE0       PSJOE
   SELECT^PSJOEA       PSJOE
   ENUDTX^PSJOREN      PSGOER
   $$ENQ^PSJORP2       PSGOE41,PSGOE81,PSGOER
   $$LASTAT^PSJORP2    PSGOER
   ADMIN^PSJORPOE      PSGOER
   $$ACTIVE^PSJORREN   PSGOER,PSGOER0
   ^PSJP               PSJOE
   ^PSJRXLAB           |opt
   $$ENBCMA^PSJUTL     PSGOE41,PSGOE81
   EFDNEW^PSJUTL       PSGOE41,PSGOER0
   EFDNV^PSJUTL        PSGOE81
   READ^PSJUTL         PSGOE7
   $$DATE^PSJUTL2      PSGOER
   $$DATE2^PSJUTL2     PSGOER,PSGOER0
   $$ENNOO^PSJUTL5     PSGOER0
   $$PROD0^PSNAPIS     PSGOE7
   PHGRP^PSOCLO1       PSJCLOZ
   $$L^PSSLOCK         PSJOE
   $$LS^PSSLOCK        PSGOER,PSJOE
   UL^PSSLOCK          PSJOE
   UNL^PSSLOCK         PSGOER,PSGOEV,PSJOE
   $$SDIMO^SDAMA203    PSJOE
   MAIN^TIUEDIT        PSGOEV
   INP^VADPT           PSJOE
   PID^VADPT           PSJRXLAB
   EN^VALM             PSGOEV,PSJOE
   FULL^VALM1          PSGOE92,PSGOEV,PSJOE
   PAUSE^VALM1         PSGOE8,PSGOE81,PSGOE82,PSGOE92,PSGOER,PSGOEV,PSJOE
   $$SITE^VASITE       PSJRXLAB
   $$FMADD^XLFDT       PSGOE81,PSGOER,PSGOER0
   $$NOW^XLFDT         PSGOER0
   $$PATCH^XPDUTL      PSJOE
   SETUP^XQALERT       PSJCLOZ
   $$DEA^XUSER         PSJCLOZ
   INPSND^YSCLTST5     PSJOE

*****   END   *****


--- END ---