Routine: PSGLPI

PSGLPI ;BIR/CML3-PATIENT INFO FOR LABELS ;12-Dec-2003 11:23;PLS

 ;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97

 ; Modified - IHS/CIA/PLS - 12/12/03 - Line ENPI+9 and ENPVSET+2

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),"^")

 S PSGLSSN=$G(VA("PID")),PSGLBS5=$G(VA("BID"))   ; IHS/CIA/PLS - 12/12/03

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

 S PSGLBS5=$G(VA("BID"))  ; IHS/CIA/PLS - 12/12/03

 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),"^")

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),!!

PSGLPI    ;BIR/CML3-PATIENT INFO FOR LABELS ;12-Dec-2003 11:23;PLS

 +1       ;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97

 +2       ; Modified - IHS/CIA/PLS - 12/12/03 - Line ENPI+9 and ENPVSET+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       ; IHS/CIA/PLS - 12/12/03

           SET PSGLSSN=$GET(VA("PID"))

           SET PSGLBS5=$GET(VA("BID"))

 +10      ;

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       ; IHS/CIA/PLS - 12/12/03

           SET PSGLBS5=$GET(VA("BID"))

 +3        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),"^")

 +4        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),"^")

 +5        QUIT

 +6       ;

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

PSGLPI.m