Routine: PSGO

PSGO ;BIR/CML3,MV-PRINTS PATIENT'S ORDERS ;10 Feb 98 / 1:32 PM

 ;;5.0; INPATIENT MEDICATIONS ;**4,58,110**;16 DEC 97

 ; Reference to ^PS(55 is is supported by DBIA #2191.

 K ^TMP("PSJON",$J),PSGONF S PSGOH="U N I T   D O S E   P R O F I L E" D ENGORD^PSGOU

EN ;

 S CML=IO'=IO(0)!($E(IOST,1,2)'="C-"),NP="" N RB

 U IO D GET I '$D(^TMP("PSG",$J)) W !,SLS,SLS,$E(SLS,1,24),!?22,"NO ORDERS FOUND" W:"SL"[PSGOL " FOR A ",$S(PSGOL="S":"SHORT",1:"LONG")," PROFILE."

 G:NP["^" DONE

 E  S (C,DRG)="",LD=0

 E  D DRG G:NP["^" DONE

 I CML,$S('$D(PSGPRP):1,1:PSGPRP="P") D BOT

DONE ;

 I $S('$D(PSGPRP):1,1:PSGPRP="P") K ^TMP("PSG",$J)

 S PSGON=$S('CML:ON,1:0) K:'$D(PSGVBW) PSGODT

D1 ;

 K C,CML,DN,DO,DRG,F,GIVE,HDT,LN2,NF,ND,ND4,ND6,NP,O,ON,PF,PG,PSGHD,PSGOH,PSJTEAM,RCT,RF,RTE,S,SCH,SD,SLS,SM,ST,STS,TF,UDU,V,WD,WS,WT Q

DRG ;

 I PSGOL'="N" F  S C=$O(^TMP("PSG",$J,C)) Q:C=""!(NP["^")  D:$S(C="BA":1,C="CC":1,C="CD":1,C["C":TF,1:1) TF F ST="C","O","OC","P","R","z" D

 .F  S DRG=$O(^TMP("PSG",$J,C,ST,DRG)) Q:DRG=""!(NP["^")  S NF=^(DRG),O=$P(DRG,"^",2),DN=$P(DRG,"^") D:$Y+4>IOSL NP Q:NP["^"  D P

 I PSGOL="N" F  S LD=$O(^TMP("PSG",$J,LD)) Q:'LD  S X=^(LD),NF=$P(X,U),C=$P(X,U,2),ST=$P(X,U,3),DN=$P(X,U,4),O=$P(LD,U,2) D P

P ;Display drug data stored in ^TMP("PSG",$J

 S ON=ON+1 I 'CML S ^TMP("PSJON",$J,ON)=+O_$S(C["CD":"",C["C":"P",C["BD":"",C["B":"P",1:"U") S:C'["O" PSGONC=ON

 Q:PSGOL="N"

 W !,$J(ON,4),?5

 I C["CD" N PSJO,OO S PSJO=O,OO=0 F  S OO=$O(^PS(53.1,"ACX",PSJO,OO)) Q:'OO  S O=OO D P2 W !

 I C["BD" N PSJO,OO S PSJO=O,OO=0 F  S OO=$O(^PS(53.1,"ACX",PSJO,OO)) Q:'OO  S O=OO D P2 W !

 Q:C["BD"  Q:C["CD"

 ; naked references below refer to full reference inside indirection @(F_+O_".0)" for either file 53.1 or 55

P2 S ND=$G(@(F_+O_",0)")),SCH=$G(^(2)),ND4=$G(^(4)),ND6=$G(^(6)),DO=$G(^(.2))

 I C="A",PSJSYSU,'$P(ND4,"^",+PSJSYSU),$P(ND4,"^",+PSJSYSU=1+9) S PSGONV=ON

 I C="A"!(C="O") S:$P(ND,"^",9)'="H"&'CML PSGONR=ON D

 .S V='$P(ND4,"^",UDU),V=$S(+PSJSYSU=1&V:1,+PSJSYSU=3&V:1,1:0)

 .W $S(ND4="":" ",$P(ND4,"^",12):"D",V!$P(ND4,"^",19)&$P(ND4,"^",18):"H",V!$P(ND4,"^",23)&$P(ND4,"^",22):"H",V!$P(ND4,"^",16)&$P(ND4,"^",15):"R",1:" ")

 .W $S($P(DO,U,4)="D":"d",1:" ")_$S(V:"->",1:"  ")

 ;I C="CA"!(C["B") W $S($P(ND4,"^",12):"D",1:" "),$S(PSJSYSU:"->",1:"") I C["B" S PSGONF=$S('$G(PSGONF):ON_U_ON,1:+PSGONF_U_ON)

 I C="CA"!(C["B") W $S($P(ND4,"^",12):"D",1:" ") I C["B" S PSGONF=$S('$G(PSGONF):ON_U_ON,1:+PSGONF_U_ON)

 S SM=2-$S('$P(ND,"^",5):2,1:$P(ND,"^",6)),STS=$S($P(ND,"^",9)]"":$P(ND,"^",9),1:"NF"),PF=$E("*",$P(ND,"^",20)>0),PSGID=$P(SCH,"^",2),SD=$P(SCH,"^",4) I C["C" S (PSGID,SD)="",PSGOD="********"

 I STS="A",($P(ND,U,27)="R") S STS="R"

 S WS=0,PSGOD=$$ENDTC^PSGMI(PSGID)

 S:PSJPWD WS=$$WS^PSJO(PSJPWD,PSGP,F,+O)

 NEW MARX

 D DRGDISP^PSJLMUT1(PSGP,+O_$S(C["B":"P",C["C":"P",1:"U"),40,54,.MARX,0)

 NEW X F X=0:0 S X=$O(MARX(X)) Q:'X  W @($S(X=1:"?9",1:"!?11")) W MARX(X) D:X=1

 . N RNDT,O2 S O2=O S:+O2=O O2=O2_"P" S RNDT=$$LASTREN^PSJLMPRI(PSGP,O2) I RNDT]"" S RNDT=$E($$ENDTC^PSGMI(RNDT),1,5)

 . W ?50,$S(C["C":"?",ST'="z":ST,1:"?"),?53,$E(PSGOD,1,5)

 . S SD=$$ENDTC^PSGMI(SD) W ?60,$E(SD,1,5),?67,STS

 . I NF!WS!SM!PF!RNDT W ?71 W:NF "NF " W:WS "WS " W:RNDT RNDT_" " W:SM $E("HSM",SM,3) W:PF ?79,"*"

 I ND6]"" S Y=$$ENSET^PSGSICHK($P(ND6,"^")) W !?11 F X=1:1:$L(Y," ") S V=$P(Y," ",X) W:$L(V)+$X>66 !?11 W V_" "

TF ;

 NEW SLS S SLS="",$P(SLS," -",40)=""

 S LN2=$S(C="A":"A C T I V E",C["CC":"P E N D I N G   R E N E W A L S",C["CD":"P E N D I N G  C O M P L E X",C["C":"P E N D I N G ",C["BD":"N O N - V E R I F E D  C O M P L E X",C["B":"N O N - V E R I F I E D",1:"N O N - A C T I V E")

 W:$D(^TMP("PSG",$J,C)) !,$E($E(SLS,1,(80-$L(LN2))/2)_" "_LN2_$E(SLS,1,(80-$L(LN2))/2),1,80)

 S F="^PS("_$S(C["C":"53.1,",C["B":"53.1,",1:"55,"_PSGP_",5,",1:"53.1,") S TF=$S(C["C":0,1:TF)

GET ;

 S $P(LN2,"-",81)="",PG=$D(PSGVWA),(ON,PSGONC,PSGONR,PSGONV,SLS)="",$P(SLS," -",15)="",TF=1,RB=$S(PSJPRB]"":PSJPRB,1:"*NF*"),WD=$S(PSJPWDN]"":PSJPWDN,PSJPWD:PSJPWD_";DIC(42,",1:"*NF*")

NP I ON,'CML W $C(7) R !," '^' TO QUIT ",NP:DTIME W:'$T $C(7) S:'$T NP="^" W:NP'["^" $C(13),"                     ",$C(13),# Q

 I ON,CML D BOT

 Q:$G(PSGOL)="N"

HEADER ;

 S PG=PG+1

 S:'$D(PSJOPC) PSJOPC=1 S PSJTEAM=$S($D(PSJSEL("TM")):1,1:0)

 D ENTRY^PSJHEAD(PSGP,PSJOPC,PG,$G(PSJNARC),PSJTEAM)

 W:PG>1 !,$E(LN2,1,80) Q

BOT ;

 F Q=$Y:1:IOSL-4 W !

 W !,?2,$P(PSGP(0),"^"),?40,PSJPPID,?70,$E($P(PSJPDOB,"^",2),1,8) Q

ENHEAD ;

 K LN2,PSGPR,PSGPRP D NOW^%DTC S HDT=$$ENDTC^PSGMI(+$E(%,1,12)),PSGVWA=1,PSGOH="U N I T   D O S E   P R O F I L E" D GET

 D D1 K PSGONC,PSGONR,PSGONV,PSGVWA Q

ENVBW ;

 S PSGOH=$S(PSGVBWTO=1:"N O N - V E R I F I E D   O R D E R S",PSGVBWTO=2:"P E N D I N G   O R D E R S",1:"N O N - V E R I F I E D / P E N D I N G   O R D E R S")

 D EN Q

ENPR ;

 S PSGOH="U N I T  D O S E  P R O F I L E" G GET

PSGO      ;BIR/CML3,MV-PRINTS PATIENT'S ORDERS ;10 Feb 98 / 1:32 PM

 +1       ;;5.0; INPATIENT MEDICATIONS ;**4,58,110**;16 DEC 97

 +2       ;

 +3       ; Reference to ^PS(55 is is supported by DBIA #2191.

 +4       ;

 +5        KILL ^TMP("PSJON",$JOB),PSGONF

           SET PSGOH="U N I T   D O S E   P R O F I L E"

           DO ENGORD^PSGOU

 +6       ;

EN        ;

 +1        SET CML=IO'=IO(0)!($EXTRACT(IOST,1,2)'="C-")

           SET NP=""

           NEW RB

 +2        USE IO

           DO GET

           IF '$DATA(^TMP("PSG",$JOB))

               WRITE !,SLS,SLS,$EXTRACT(SLS,1,24),!?22,"NO ORDERS FOUND"

               IF "SL"[PSGOL

                   WRITE " FOR A ",$SELECT(PSGOL="S":"SHORT",1:"LONG")," PROFILE."

 +3        IF NP["^"

               GOTO DONE

 +4       IF '$TEST

               SET (C,DRG)=""

               SET LD=0

 +5       IF '$TEST

               DO DRG

               IF NP["^"

                   GOTO DONE

 +6        IF CML

               IF $SELECT('$DATA(PSGPRP):1,1:PSGPRP="P")

                   DO BOT

 +7       ;

DONE      ;

 +1        IF $SELECT('$DATA(PSGPRP):1,1:PSGPRP="P")

               KILL ^TMP("PSG",$JOB)

 +2        SET PSGON=$SELECT('CML:ON,1:0)

           IF '$DATA(PSGVBW)

               KILL PSGODT

 +3       ;

D1        ;

 +1        KILL C,CML,DN,DO,DRG,F,GIVE,HDT,LN2,NF,ND,ND4,ND6,NP,O,ON,PF,PG,PSGHD,PSGOH,PSJTEAM,RCT,RF,RTE,S,SCH,SD,SLS,SM,ST,STS,TF,UDU,V,WD,WS,WT

           QUIT

 +2       ;

DRG       ;

 +1        IF PSGOL'="N"

FOR

                   SET C=$ORDER(^TMP("PSG",$JOB,C))

                   IF C=""!(NP["^")

                       QUIT

                   IF $SELECT(C="BA"

                       DO TF

                   FOR ST="C","O","OC","P","R","z"

                       Begin DoDot:1

 +2                        FOR

                               SET DRG=$ORDER(^TMP("PSG",$JOB,C,ST,DRG))

                               IF DRG=""!(NP["^")

                                   QUIT

                               SET NF=^(DRG)

                               SET O=$PIECE(DRG,"^",2)

                               SET DN=$PIECE(DRG,"^")

                               IF $Y+4>IOSL

                                   DO NP

                               IF NP["^"

                                   QUIT

                               DO P

                       End DoDot:1

 +3        IF PSGOL="N"

FOR

                   SET LD=$ORDER(^TMP("PSG",$JOB,LD))

                   IF 'LD

                       QUIT

                   SET X=^(LD)

                   SET NF=$PIECE(X,U)

                   SET C=$PIECE(X,U,2)

                   SET ST=$PIECE(X,U,3)

                   SET DN=$PIECE(X,U,4)

                   SET O=$PIECE(LD,U,2)

                   DO P

 +4        QUIT

 +5       ;

P         ;Display drug data stored in ^TMP("PSG",$J

 +1        SET ON=ON+1

           IF 'CML

               SET ^TMP("PSJON",$JOB,ON)=+O_$SELECT(C["CD":"",C["C":"P",C["BD":"",C["B":"P",1:"U")

               IF C'["O"

                   SET PSGONC=ON

 +2        IF PSGOL="N"

               QUIT

 +3        WRITE !,$JUSTIFY(ON,4),?5

 +4        IF C["CD"

               NEW PSJO,OO

               SET PSJO=O

               SET OO=0

FOR

                   SET OO=$ORDER(^PS(53.1,"ACX",PSJO,OO))

                   IF 'OO

                       QUIT

                   SET O=OO

                   DO P2

                   WRITE !

 +5        IF C["BD"

               NEW PSJO,OO

               SET PSJO=O

               SET OO=0

FOR

                   SET OO=$ORDER(^PS(53.1,"ACX",PSJO,OO))

                   IF 'OO

                       QUIT

                   SET O=OO

                   DO P2

                   WRITE !

 +6        IF C["BD"

               QUIT

           IF C["CD"

               QUIT

 +7       ; naked references below refer to full reference inside indirection @(F_+O_".0)" for either file 53.1 or 55

P2         SET ND=$GET(@(F_+O_",0)"))

           SET SCH=$GET(^(2))

           SET ND4=$GET(^(4))

           SET ND6=$GET(^(6))

           SET DO=$GET(^(.2))

 +1        IF C="A"

               IF PSJSYSU

                   IF '$PIECE(ND4,"^",+PSJSYSU)

                       IF $PIECE(ND4,"^",+PSJSYSU=1+9)

                           SET PSGONV=ON

 +2        IF C="A"!(C="O")

               IF $PIECE(ND,"^",9)'="H"&'CML

                   SET PSGONR=ON

               Begin DoDot:1

 +3                SET V='$PIECE(ND4,"^",UDU)

                   SET V=$SELECT(+PSJSYSU=1&V:1,+PSJSYSU=3&V:1,1:0)

 +4                WRITE $SELECT(ND4="":" ",$PIECE(ND4,"^",12):"D",V!$PIECE(ND4,"^",19)&$PIECE(ND4,"^",18):"H",V!$PIECE(ND4,"^",23)&$PIECE(ND4,"^",22):"H",V!$PIECE(ND4,"^",16)&$PIECE(ND4,"^",15):"R",1:" ")

 +5                WRITE $SELECT($PIECE(DO,U,4)="D":"d",1:" ")_$SELECT(V:"->",1:"  ")

               End DoDot:1

 +6       ;I C="CA"!(C["B") W $S($P(ND4,"^",12):"D",1:" "),$S(PSJSYSU:"->",1:"") I C["B" S PSGONF=$S('$G(PSGONF):ON_U_ON,1:+PSGONF_U_ON)

 +7        IF C="CA"!(C["B")

               WRITE $SELECT($PIECE(ND4,"^",12):"D",1:" ")

               IF C["B"

                   SET PSGONF=$SELECT('$GET(PSGONF):ON_U_ON,1:+PSGONF_U_ON)

 +8        SET SM=2-$SELECT('$PIECE(ND,"^",5):2,1:$PIECE(ND,"^",6))

           SET STS=$SELECT($PIECE(ND,"^",9)]"":$PIECE(ND,"^",9),1:"NF")

           SET PF=$EXTRACT("*",$PIECE(ND,"^",20)>0)

           SET PSGID=$PIECE(SCH,"^",2)

           SET SD=$PIECE(SCH,"^",4)

           IF C["C"

               SET (PSGID,SD)=""

               SET PSGOD="********"

 +9        IF STS="A"

               IF ($PIECE(ND,U,27)="R")

                   SET STS="R"

 +10       SET WS=0

           SET PSGOD=$$ENDTC^PSGMI(PSGID)

 +11       IF PSJPWD

               SET WS=$$WS^PSJO(PSJPWD,PSGP,F,+O)

 +12       NEW MARX

 +13       DO DRGDISP^PSJLMUT1(PSGP,+O_$SELECT(C["B":"P",C["C":"P",1:"U"),40,54,.MARX,0)

 +14       NEW X

           FOR X=0:0

               SET X=$ORDER(MARX(X))

               IF 'X

                   QUIT

               WRITE @($SELECT(X=1:"?9",1:"!?11"))

               WRITE MARX(X)

               IF X=1

                   Begin DoDot:1

 +15                   NEW RNDT,O2

                       SET O2=O

                       IF +O2=O

                           SET O2=O2_"P"

                       SET RNDT=$$LASTREN^PSJLMPRI(PSGP,O2)

                       IF RNDT]""

                           SET RNDT=$EXTRACT($$ENDTC^PSGMI(RNDT),1,5)

 +16                   WRITE ?50,$SELECT(C["C":"?",ST'="z":ST,1:"?"),?53,$EXTRACT(PSGOD,1,5)

 +17                   SET SD=$$ENDTC^PSGMI(SD)

                       WRITE ?60,$EXTRACT(SD,1,5),?67,STS

 +18                   IF NF!WS!SM!PF!RNDT

                           WRITE ?71

                           IF NF

                               WRITE "NF "

                           IF WS

                               WRITE "WS "

                           IF RNDT

                               WRITE RNDT_" "

                           IF SM

                               WRITE $EXTRACT("HSM",SM,3)

                           IF PF

                               WRITE ?79,"*"

                   End DoDot:1

 +19       IF ND6]""

               SET Y=$$ENSET^PSGSICHK($PIECE(ND6,"^"))

               WRITE !?11

               FOR X=1:1:$LENGTH(Y," ")

                   SET V=$PIECE(Y," ",X)

                   IF $LENGTH(V)+$X>66

                       WRITE !?11

                   WRITE V_" "

 +20       QUIT

 +21      ;

TF        ;

 +1        NEW SLS

           SET SLS=""

           SET $PIECE(SLS," -",40)=""

 +2        SET LN2=$SELECT(C="A":"A C T I V E",C["CC":"P E N D I N G   R E N E W A L S",C["CD":"P E N D I N G  C O M P L E X",C["C":"P E N D I N G ",C["BD":"N O N - V E R I F E D  C O M P L E X",C["B":"N O N - V E R I F I E D",1:"N O N - A C T I V E")

 +3        IF $DATA(^TMP("PSG",$JOB,C))

               WRITE !,$EXTRACT($EXTRACT(SLS,1,(80-$LENGTH(LN2))/2)_" "_LN2_$EXTRACT(SLS,1,(80-$LENGTH(LN2))/2),1,80)

 +4        SET F="^PS("_$SELECT(C["C":"53.1,",C["B":"53.1,",1:"55,"_PSGP_",5,",1:"53.1,")

           SET TF=$SELECT(C["C":0,1:TF)

 +5        QUIT

 +6       ;

GET       ;

 +1        SET $PIECE(LN2,"-",81)=""

           SET PG=$DATA(PSGVWA)

           SET (ON,PSGONC,PSGONR,PSGONV,SLS)=""

           SET $PIECE(SLS," -",15)=""

           SET TF=1

           SET RB=$SELECT(PSJPRB]"":PSJPRB,1:"*NF*")

           SET WD=$SELECT(PSJPWDN]"":PSJPWDN,PSJPWD:PSJPWD_";DIC(42,",1:"*NF*")

 +2       ;

NP         IF ON

               IF 'CML

                   WRITE $CHAR(7)

                   READ !," '^' TO QUIT ",NP:DTIME

                   IF '$TEST

                       WRITE $CHAR(7)

                   IF '$TEST

                       SET NP="^"

                   IF NP'["^"

                       WRITE $CHAR(13),"                     ",$CHAR(13),#

                   QUIT

 +1        IF ON

               IF CML

                   DO BOT

 +2        IF $GET(PSGOL)="N"

               QUIT

 +3       ;

HEADER    ;

 +1        SET PG=PG+1

 +2        IF '$DATA(PSJOPC)

               SET PSJOPC=1

           SET PSJTEAM=$SELECT($DATA(PSJSEL("TM")):1,1:0)

 +3        DO ENTRY^PSJHEAD(PSGP,PSJOPC,PG,$GET(PSJNARC),PSJTEAM)

 +4        IF PG>1

               WRITE !,$EXTRACT(LN2,1,80)

           QUIT

 +5       ;

BOT       ;

 +1        FOR Q=$Y:1:IOSL-4

               WRITE !

 +2        WRITE !,?2,$PIECE(PSGP(0),"^"),?40,PSJPPID,?70,$EXTRACT($PIECE(PSJPDOB,"^",2),1,8)

           QUIT

 +3       ;

ENHEAD    ;

 +1        KILL LN2,PSGPR,PSGPRP

           DO NOW^%DTC

           SET HDT=$$ENDTC^PSGMI(+$EXTRACT(%,1,12))

           SET PSGVWA=1

           SET PSGOH="U N I T   D O S E   P R O F I L E"

           DO GET

 +2        DO D1

           KILL PSGONC,PSGONR,PSGONV,PSGVWA

           QUIT

 +3       ;

ENVBW     ;

 +1        SET PSGOH=$SELECT(PSGVBWTO=1:"N O N - V E R I F I E D   O R D E R S",PSGVBWTO=2:"P E N D I N G   O R D E R S",1:"N O N - V E R I F I E D / P E N D I N G   O R D E R S")

 +2        DO EN

           QUIT

ENPR      ;

 +1        SET PSGOH="U N I T  D O S E  P R O F I L E"

           GOTO GET

 +2        QUIT

PSGO.m