PSGLPI ;BIR/CML3-PATIENT INFO FOR LABELS ;15 DEC 95 / 10:26 AM
;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
;
ENPI ;
N VADM,VAIN,VAIP,PSGLWG S DFN=PSGOP D DEM^VADPT,INP^VADPT S PSGLPID=VA("PID"),PSGLBID=VA("BID")
I 'VAIN(4) S VAIP("D")="L" D IN5^VADPT
I VAIN(4) S PSGLWD=+VAIN(4),PSGLWDN=$P(VAIN(4),"^",2) S PSGLPR=VAIN(2),PSGLTS=VAIN(3),PSGLRB=VAIN(5),PSGLAD=+VAIN(7),PSGLDX=VAIN(9)
E S:$S('$D(PSGLWD):1,1:'PSGLWD) PSGLWD=+VAIP(5),PSGLWDN=$P(VAIP(5),"^",2) S PSGLRB=$P(VAIP(6),"^",2),PSGLPR=VAIP(7),PSGLTS=VAIP(8),PSGLDX=VAIP(9)
S PSGLTM="" I PSGLWD,PSGLRB]"",$D(^PS(57.7,PSGLWD,1,+$O(^PS(57.7,"AWRT",PSGLWD,PSGLRB,0)),0)) S PSGLTM=$P(^(0),"^")
D NOW^%DTC S PSGLDT=+$E(%,1,12)
S PSGLPN=VADM(1),PSGLSSN=$P(VADM(2),"^",2),PSGLDOB=$E($$ENDTC^PSGMI(+VADM(3)),1,8),PSGLAGE=VADM(4),PSGLSEX=$S(VADM(5)]"":$P(VADM(5),"^",2),1:"____")
S PSGLBS5=$E(PSGLPN)_$P(PSGLSSN,"-",3) I $S('$D(PSGLWG):1,1:'PSGLWG) S (PSGLWG,PSGLWGN)="" S PSGLWG=$O(^PS(57.5,"AB",PSGLWD,0)) I PSGLWG,$D(^PS(57.5,PSGLWG,0)) S PSGLWGN=$P(^(0),"^")
;
DONE ;
K PSGLPIWF,PSGID,PSGOD,VADM,VAIN,VAIP Q
;
ENPVSET ;
S PSGLAD=+PSJPAD,PSGLAGE=PSJPAGE,PSGLBS5=$E(PSGP(0))_$E($P(PSJPSSN,"^"),6,10),PSGLDOB=$E($P(PSJPDOB,"^",2),1,8),PSGLDX=PSJPDX,PSGLPN=$P(PSGP(0),"^"),PSGLRB=PSJPRB,PSGLSEX=$P(PSJPSEX,"^",2),PSGLSSN=VA("PID"),PSGLWD=PSJPWD,PSGLWDN=PSJPWDN
I $S('$D(PSGLWG):1,1:'PSGLWG) S (PSGLWG,PSGLWGN)="" I PSGLWD S PSGLWG=$O(^PS(57.5,"AB",PSGLWD,0)) I PSGLWG,$D(^PS(57.5,PSGLWG,0)) S PSGLWGN=$P(^(0),"^")
S PSGLTM="" I PSGLWD,PSGLRB]"",$D(^PS(57.7,PSGLWD,1,+$O(^PS(57.7,"AWRT",PSGLWD,PSGLRB,0)),0)) S PSGLTM=$P(^(0),"^")
Q
;
ENHEDER ; Print MAR header labels.
N NF S NF="NOT FOUND"
W *13,?52,PSGLPN,?88,$J($S(PSGLRB]"":PSGLRB,1:"*NF*"),12)
W !?(41-$L(PSGLPN)/2),"*** ",PSGLPN," ***",?52,PSGLSSN,?70,PSGLDOB," (",PSGLAGE,")",?85,$J($S(PSGLTM]"":PSGLTM,1:NF),15)
W !?18,PSGLSSN,?52,$S(PSGLSEX]"":PSGLSEX,1:"____"),?65,"DX: ",PSGLDX
D NOW^%DTC W !?52,$$ENDTC^PSGMI(%),!?52,$S(PSGLWGN]"":$E(PSGLWGN,1,21),1:NF),?79,$J($S(PSGLWDN]"":PSGLWDN,1:NF),21),!!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGLPI 2057 printed Sep 23, 2025@19:37:31 Page 2
PSGLPI ;BIR/CML3-PATIENT INFO FOR LABELS ;15 DEC 95 / 10:26 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
+2 ;
ENPI ;
+1 NEW VADM,VAIN,VAIP,PSGLWG
SET DFN=PSGOP
DO DEM^VADPT
DO INP^VADPT
SET PSGLPID=VA("PID")
SET PSGLBID=VA("BID")
+2 IF 'VAIN(4)
SET VAIP("D")="L"
DO IN5^VADPT
+3 IF VAIN(4)
SET PSGLWD=+VAIN(4)
SET PSGLWDN=$PIECE(VAIN(4),"^",2)
SET PSGLPR=VAIN(2)
SET PSGLTS=VAIN(3)
SET PSGLRB=VAIN(5)
SET PSGLAD=+VAIN(7)
SET PSGLDX=VAIN(9)
+4 IF '$TEST
if $SELECT('$DATA(PSGLWD)
SET PSGLWD=+VAIP(5)
SET PSGLWDN=$PIECE(VAIP(5),"^",2)
SET PSGLRB=$PIECE(VAIP(6),"^",2)
SET PSGLPR=VAIP(7)
SET PSGLTS=VAIP(8)
SET PSGLDX=VAIP(9)
+5 SET PSGLTM=""
IF PSGLWD
IF PSGLRB]""
IF $DATA(^PS(57.7,PSGLWD,1,+$ORDER(^PS(57.7,"AWRT",PSGLWD,PSGLRB,0)),0))
SET PSGLTM=$PIECE(^(0),"^")
+6 DO NOW^%DTC
SET PSGLDT=+$EXTRACT(%,1,12)
+7 SET PSGLPN=VADM(1)
SET PSGLSSN=$PIECE(VADM(2),"^",2)
SET PSGLDOB=$EXTRACT($$ENDTC^PSGMI(+VADM(3)),1,8)
SET PSGLAGE=VADM(4)
SET PSGLSEX=$SELECT(VADM(5)]"":$PIECE(VADM(5),"^",2),1:"____")
+8 SET PSGLBS5=$EXTRACT(PSGLPN)_$PIECE(PSGLSSN,"-",3)
IF $SELECT('$DATA(PSGLWG):1,1:'PSGLWG)
SET (PSGLWG,PSGLWGN)=""
SET PSGLWG=$ORDER(^PS(57.5,"AB",PSGLWD,0))
IF PSGLWG
IF $DATA(^PS(57.5,PSGLWG,0))
SET PSGLWGN=$PIECE(^(0),"^")
+9 ;
DONE ;
+1 KILL PSGLPIWF,PSGID,PSGOD,VADM,VAIN,VAIP
QUIT
+2 ;
ENPVSET ;
+1 SET PSGLAD=+PSJPAD
SET PSGLAGE=PSJPAGE
SET PSGLBS5=$EXTRACT(PSGP(0))_$EXTRACT($PIECE(PSJPSSN,"^"),6,10)
SET PSGLDOB=$EXTRACT($PIECE(PSJPDOB,"^",2),1,8)
SET PSGLDX=PSJPDX
SET PSGLPN=$PIECE(PSGP(0),"^")
SET PSGLRB=PSJPRB
SET PSGLSEX=$PIECE(PSJPSEX,"^",2)
SET PSGLSSN=VA("PID")
SET PSGLWD=PSJPWD
SET PSGLWDN=PSJPWDN
+2 IF $SELECT('$DATA(PSGLWG):1,1:'PSGLWG)
SET (PSGLWG,PSGLWGN)=""
IF PSGLWD
SET PSGLWG=$ORDER(^PS(57.5,"AB",PSGLWD,0))
IF PSGLWG
IF $DATA(^PS(57.5,PSGLWG,0))
SET PSGLWGN=$PIECE(^(0),"^")
+3 SET PSGLTM=""
IF PSGLWD
IF PSGLRB]""
IF $DATA(^PS(57.7,PSGLWD,1,+$ORDER(^PS(57.7,"AWRT",PSGLWD,PSGLRB,0)),0))
SET PSGLTM=$PIECE(^(0),"^")
+4 QUIT
+5 ;
ENHEDER ; Print MAR header labels.
+1 NEW NF
SET NF="NOT FOUND"
+2 WRITE *13,?52,PSGLPN,?88,$JUSTIFY($SELECT(PSGLRB]"":PSGLRB,1:"*NF*"),12)
+3 WRITE !?(41-$LENGTH(PSGLPN)/2),"*** ",PSGLPN," ***",?52,PSGLSSN,?70,PSGLDOB," (",PSGLAGE,")",?85,$JUSTIFY($SELECT(PSGLTM]"":PSGLTM,1:NF),15)
+4 WRITE !?18,PSGLSSN,?52,$SELECT(PSGLSEX]"":PSGLSEX,1:"____"),?65,"DX: ",PSGLDX
+5 DO NOW^%DTC
WRITE !?52,$$ENDTC^PSGMI(%),!?52,$SELECT(PSGLWGN]"":$EXTRACT(PSGLWGN,1,21),1:NF),?79,$JUSTIFY($SELECT(PSGLWDN]"":PSGLWDN,1:NF),21),!!
+6 QUIT
