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
Q
;
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_" "
Q
;
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)
Q
;
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"
;
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
Q
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 ;
+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
