PSJO2 ;BIRC/CML3,PR-INPATIENT ORDERS - PRINT ;17 SEP 97 / 1:41 PM
;;5.0;INPATIENT MEDICATIONS ;**58,317**;16 DEC 97;Build 130
;
; Reference to ^PS(51.2 is supported by DBIA 2178.
; Reference to ^PS(55 is supported by DBIA 2191.
; Reference to ^PSI(58.1 is supported by DBIA 2284.
;
F S PSJC=$O(^UTILITY("PSG",$J,PSJC)) Q:PSJC="" D TF F PSJST="C","O","OC","P","R","z" S PSJDRG="" F S PSJDRG=$O(^UTILITY("PSG",$J,PSJC,PSJST,PSJDRG)) Q:PSJDRG="" S NF=^(PSJDRG) D:$Y+4>IOSL NP G:PSJNP["^" DONE D P
I PSJTD,$S('$D(PSGPRP):1,1:PSGPRP="P") D BOT
;
DONE ;
I $S('$D(PSGPRP):1,1:PSGPRP="P") K ^UTILITY("PSG",$J)
S PSGON=PSJON K:'$D(PSGVBW) PSGODT K C,PSJTD,DO,DOB,PSJDRG,F,GIVE,HDT,LN2,NF,ND,PSJNP,O,ON,PG,PSGID,PSGOD,RF,RTE,SCH,SD,SLS,SM,SSN,PADE,PSJST,TF,PSJU,V,WD,WDP,WS,WT Q
;
P ; data printed here
S O=$P(PSJDRG,"^",2),DN=$P(PSJDRG,"^"),PSJON=PSJON+1 S:'PSJTD ^TMP("PSJON",$J,PSJON)=O_PSJC W !,$J(PSJON,4),?5
I C["A" S ND=$S($D(^PS(55,PSGP,5,O,4)):^(4),1:""),V='$P(ND,"^",PSJU) ; $S(PSJSYSU:PSJSYSU,1:1))
I W $S(ND="":" ",$P(ND,"^",12):"D",$P(ND,"^",18)&($P(ND,"^",19)!V):"H",$P(ND,"^",22)&($P(ND,"^",23)!V):"H",$P(ND,"^",15)&($P(ND,"^",16)!V):"R",1:" ") W:V "->"
I C["N" W $S('$D(^PS(53.1,O,4)):" ",$P(^(4),"^",12):"D",1:" "),$S(PSJSYSU:"->",1:"")
S ND=$G(@(PSJF_O_",0)")),SCH=$G(^(2)),Y=$P($G(^(6)),"^"),DO=$G(^(.1)) I Y]"" S Y=$$ENSET^PSGSICHK(Y)
S RTE=$P(ND,"^",3),SM=$S('$P(ND,"^",5):0,$P(ND,"^",6):1,1:2),X=$S($P(ND,"^",9)]"":$P(ND,"^",9),1:"NF")_$E("*",$P(ND,"^",20)),PSGID=$P(SCH,"^",2),SD=$P(SCH,"^",4),SCH=$P(SCH,"^")
I C'["N",$P(ND,"^",22) S GIVE="*** NOT TO BE GIVEN ***"
E S RTE=$S('RTE:"N/F",'$D(^PS(51.2,RTE,0)):RTE,$P(^(0),"^",3)]"":$P(^(0),"^",3),$P(^(0),"^")]"":$P(^(0),"^"),1:RTE),GIVE="Give: "_$S($P(DO,"^",2)]"":$P(DO,"^",2)_" ",1:"")_" "_RTE_" "_$S(SCH]"":SCH,1:"SCHEDULE NOT FOUND")
S WS=$S(DO&PSGPWD:$D(^PSI(58.1,"D",+DO,PSGPWD)),1:0)
N PSJTMNOE S PSJTMNOE=$G(PSJNEWOE) N PSJNEWOE S PSJNEWOE=PSJTMNOE ; PSJ*5*317-PADE
S PADE=$$DRGFLAG^PSJPADSI(PSGP,$G(O),,$G(O),$G(PSJNEWOE)) S:PADE=0 PADE=1
W ?9,$S(DN'="z":DN,1:"NOT FOUND"),?50,$S(PSJST'="z":PSJST,1:"?"),?53,$E($$ENDTC^PSGMI(PSGID),1,5),?60,$E($$ENDTC^PSGMI(SD),1,5),?67,X I NF!WS!SM W ?71 W:NF "NF " W:(WS&PADE) "WP" W:(PADE&'WS) "PD" W:(WS&'PADE) "WS " W:SM $E("HSM",SM,3)
W !?11,GIVE I Y]"" W !?10 F X=1:1:$L(Y," ") S V=$P(Y," ",X) W:$L(V)+$X>77 !?10 W V_" "
Q
;
PIV ; print IV order
;
TF ;
Q:PSJC["N"&'PSJTF S PSJLN2=PSJSLS_$S(PSJC["A":" - - - A C T I V E - - -",PSJC["N":" N O N - V E R I F I E D",1:" - N O N - A C T I V E -")_PSJSLS W:$D(^UTILITY("PSG",$J,PSJC)) !,PSJLN2
S PSJF="^PS("_$S(PSJC'["N":"55,"_PSGP_",5,",1:"53.1,") S:PSJC["N" TF=0 Q
;
NP I PSJON,'PSJTD W $C(7) R !," `^' TO QUIT ",PSJNP:DTIME W:'$T $C(7) S:'$T PSJNP="^" W:PSJNP'["^" $C(13)," ",$C(13),# Q
I PSJON,PSJTD D BOT
;
S PSJPG=PSJPG+1,PSGOD=$$ENDTC^PSGMI(PSGPAD)
W @IOF,! W:$D(PSGPR) ?22,"U N I T D O S E P R O F I L E" W ?64,HDT,! W:$D(PSGPR) PSJSLS,PSJSLS,$E(PSJSLS,1,24),! W ?1,$P(PSGP(0),"^"),?34," Ward: ",$S(PSGPWDN]"":PSGPWDN,1:"* NF *") W:$D(PSGPR) ?75-$L(PSJPG),"Pg: ",PG-$D(PSGVWA)
W !?7,"PID: ",PSJPPID,?30,"WEIGHT(kg): ",PSJPWT,?48,"Sex: ",$P(PSJPSEX,"^",2),?61,"Admitted: ",$E(PSGOD,1,8),!?7,"DOB: ",DOB_" ("_AGE_")",?30,"Height(cm): ",PSJPHT
S PSGID=$S(PSGPDD:PSGPDD,1:PSGPTD) I PSGID W ?$S(PSGPDD:59,1:53),$S(PSGPDD:"Discharged: ",1:"Last transferred: "),$E($$ENDTC^PSGMI(PSGID),1,8)
W !?8,"Dx: ",$S(PSGPDX]"":PSGPDX,1:"* NF *"),?69-$L(RB),"Room-Bed: ",RB,!?1,"Reactions:" D ENRCT^PSGAPP I $D(^PS(55,PSGP,5.1)),$P(^(5.1),"^",7) W $C(7),!!?21,"** PATIENT'S ORDERS PLACED ON HOLD **"
I '$D(PSGVWA),$S('$D(PSGPRP):1,1:PSGPRP'="E") W !!," No.",?19,"Drug",?50,"ST Start Stop Status/Info"
W:PSJPG>1 !,PSJLN2 Q
;
BOT ; print name, ssn, and dob on bottom of page
F Q=$Y:1:IOSL-4 W !
W !,?2,$P(PSGP(0),"^"),?40,SSN,?60,DOB Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJO2 3962 printed Dec 13, 2024@02:07:56 Page 2
PSJO2 ;BIRC/CML3,PR-INPATIENT ORDERS - PRINT ;17 SEP 97 / 1:41 PM
+1 ;;5.0;INPATIENT MEDICATIONS ;**58,317**;16 DEC 97;Build 130
+2 ;
+3 ; Reference to ^PS(51.2 is supported by DBIA 2178.
+4 ; Reference to ^PS(55 is supported by DBIA 2191.
+5 ; Reference to ^PSI(58.1 is supported by DBIA 2284.
+6 ;
+7 FOR
SET PSJC=$ORDER(^UTILITY("PSG",$JOB,PSJC))
if PSJC=""
QUIT
DO TF
FOR PSJST="C","O","OC","P","R","z"
SET PSJDRG=""
FOR
SET PSJDRG=$ORDER(^UTILITY("PSG",$JOB,PSJC,PSJST,PSJDRG))
if PSJDRG=""
QUIT
SET NF=^(PSJDRG)
if $Y+4>IOSL
DO NP
if PSJNP["^"
GOTO DONE
DO P
+8 IF PSJTD
IF $SELECT('$DATA(PSGPRP):1,1:PSGPRP="P")
DO BOT
+9 ;
DONE ;
+1 IF $SELECT('$DATA(PSGPRP):1,1:PSGPRP="P")
KILL ^UTILITY("PSG",$JOB)
+2 SET PSGON=PSJON
if '$DATA(PSGVBW)
KILL PSGODT
KILL C,PSJTD,DO,DOB,PSJDRG,F,GIVE,HDT,LN2,NF,ND,PSJNP,O,ON,PG,PSGID,PSGOD,RF,RTE,SCH,SD,SLS,SM,SSN,PADE,PSJST,TF,PSJU,V,WD,WDP,WS,WT
QUIT
+3 ;
P ; data printed here
+1 SET O=$PIECE(PSJDRG,"^",2)
SET DN=$PIECE(PSJDRG,"^")
SET PSJON=PSJON+1
if 'PSJTD
SET ^TMP("PSJON",$JOB,PSJON)=O_PSJC
WRITE !,$JUSTIFY(PSJON,4),?5
+2 ; $S(PSJSYSU:PSJSYSU,1:1))
IF C["A"
SET ND=$SELECT($DATA(^PS(55,PSGP,5,O,4)):^(4),1:"")
SET V='$PIECE(ND,"^",PSJU)
+3 IF $TEST
WRITE $SELECT(ND="":" ",$PIECE(ND,"^",12):"D",$PIECE(ND,"^",18)&($PIECE(ND,"^",19)!V):"H",$PIECE(ND,"^",22)&($PIECE(ND,"^",23)!V):"H",$PIECE(ND,"^",15)&($PIECE(ND,"^",16)!V):"R",1:" ")
if V
WRITE "->"
+4 IF C["N"
WRITE $SELECT('$DATA(^PS(53.1,O,4)):" ",$PIECE(^(4),"^",12):"D",1:" "),$SELECT(PSJSYSU:"->",1:"")
+5 SET ND=$GET(@(PSJF_O_",0)"))
SET SCH=$GET(^(2))
SET Y=$PIECE($GET(^(6)),"^")
SET DO=$GET(^(.1))
IF Y]""
SET Y=$$ENSET^PSGSICHK(Y)
+6 SET RTE=$PIECE(ND,"^",3)
SET SM=$SELECT('$PIECE(ND,"^",5):0,$PIECE(ND,"^",6):1,1:2)
SET X=$SELECT($PIECE(ND,"^",9)]"":$PIECE(ND,"^",9),1:"NF")_$EXTRACT("*",$PIECE(ND,"^",20))
SET PSGID=$PIECE(SCH,"^",2)
SET SD=$PIECE(SCH,"^",4)
SET SCH=$PIECE(SCH,"^")
+7 IF C'["N"
IF $PIECE(ND,"^",22)
SET GIVE="*** NOT TO BE GIVEN ***"
+8 IF '$TEST
SET RTE=$SELECT('RTE:"N/F",'$DATA(^PS(51.2,RTE,0)):RTE,$PIECE(^(0),"^",3)]"":$PIECE(^(0),"^",3),$PIECE(^(0),"^")]"":$PIECE(^(0),"^"),1:RTE)
SET GIVE="Give: "_$SELECT($PIECE(DO,"^",2)]"":$PIECE(DO,"^",2)_" ",1:"")_" "_RTE_" "_$SELECT(SCH]"":SCH,1:"SCHEDULE NOT FOUND")
+9 SET WS=$SELECT(DO&PSGPWD:$DATA(^PSI(58.1,"D",+DO,PSGPWD)),1:0)
+10 ; PSJ*5*317-PADE
NEW PSJTMNOE
SET PSJTMNOE=$GET(PSJNEWOE)
NEW PSJNEWOE
SET PSJNEWOE=PSJTMNOE
+11 SET PADE=$$DRGFLAG^PSJPADSI(PSGP,$GET(O),,$GET(O),$GET(PSJNEWOE))
if PADE=0
SET PADE=1
+12 WRITE ?9,$SELECT(DN'="z":DN,1:"NOT FOUND"),?50,$SELECT(PSJST'="z":PSJST,1:"?"),?53,$EXTRACT($$ENDTC^PSGMI(PSGID),1,5),?60,$EXTRACT($$ENDTC^PSGMI(SD),1,5),?67,X
IF NF!WS!SM
WRITE ?71
if NF
WRITE "NF "
if (WS&PADE)
WRITE "WP"
if (PADE&'WS)
WRITE "PD"
if (WS&'PADE)
WRITE "WS "
if SM
WRITE $EXTRACT("HSM",SM,3)
+13 WRITE !?11,GIVE
IF Y]""
WRITE !?10
FOR X=1:1:$LENGTH(Y," ")
SET V=$PIECE(Y," ",X)
if $LENGTH(V)+$X>77
WRITE !?10
WRITE V_" "
+14 QUIT
+15 ;
PIV ; print IV order
+1 ;
TF ;
+1 if PSJC["N"&'PSJTF
QUIT
SET PSJLN2=PSJSLS_$SELECT(PSJC["A":" - - - A C T I V E - - -",PSJC["N":" N O N - V E R I F I E D",1:" - N O N - A C T I V E -")_PSJSLS
if $DATA(^UTILITY("PSG",$JOB,PSJC))
WRITE !,PSJLN2
+2 SET PSJF="^PS("_$SELECT(PSJC'["N":"55,"_PSGP_",5,",1:"53.1,")
if PSJC["N"
SET TF=0
QUIT
+3 ;
NP IF PSJON
IF 'PSJTD
WRITE $CHAR(7)
READ !," `^' TO QUIT ",PSJNP:DTIME
if '$TEST
WRITE $CHAR(7)
if '$TEST
SET PSJNP="^"
if PSJNP'["^"
WRITE $CHAR(13)," ",$CHAR(13),#
QUIT
+1 IF PSJON
IF PSJTD
DO BOT
+2 ;
+1 SET PSJPG=PSJPG+1
SET PSGOD=$$ENDTC^PSGMI(PSGPAD)
+2 WRITE @IOF,!
if $DATA(PSGPR)
WRITE ?22,"U N I T D O S E P R O F I L E"
WRITE ?64,HDT,!
if $DATA(PSGPR)
WRITE PSJSLS,PSJSLS,$EXTRACT(PSJSLS,1,24),!
WRITE ?1,$PIECE(PSGP(0),"^"),?34," Ward: ",$SELECT(PSGPWDN]"":PSGPWDN,1:"* NF *")
if $DATA(PSGPR)
WRITE ?75-$LENGTH(PSJPG),"Pg: ",PG-$DATA(PSGVWA)
+3 WRITE !?7,"PID: ",PSJPPID,?30,"WEIGHT(kg): ",PSJPWT,?48,"Sex: ",$PIECE(PSJPSEX,"^",2),?61,"Admitted: ",$EXTRACT(PSGOD,1,8),!?7,"DOB: ",DOB_" ("_AGE_")",?30,"Height(cm): ",PSJPHT
+4 SET PSGID=$SELECT(PSGPDD:PSGPDD,1:PSGPTD)
IF PSGID
WRITE ?$SELECT(PSGPDD:59,1:53),$SELECT(PSGPDD:"Discharged: ",1:"Last transferred: "),$EXTRACT($$ENDTC^PSGMI(PSGID),1,8)
+5 WRITE !?8,"Dx: ",$SELECT(PSGPDX]"":PSGPDX,1:"* NF *"),?69-$LENGTH(RB),"Room-Bed: ",RB,!?1,"Reactions:"
DO ENRCT^PSGAPP
IF $DATA(^PS(55,PSGP,5.1))
IF $PIECE(^(5.1),"^",7)
WRITE $CHAR(7),!!?21,"** PATIENT'S ORDERS PLACED ON HOLD **"
+6 IF '$DATA(PSGVWA)
IF $SELECT('$DATA(PSGPRP):1,1:PSGPRP'="E")
WRITE !!," No.",?19,"Drug",?50,"ST Start Stop Status/Info"
+7 if PSJPG>1
WRITE !,PSJLN2
QUIT
+8 ;
BOT ; print name, ssn, and dob on bottom of page
+1 FOR Q=$Y:1:IOSL-4
WRITE !
+2 WRITE !,?2,$PIECE(PSGP(0),"^"),?40,SSN,?60,DOB
QUIT
