PSJHEAD ;BIR/KKA-PROFILE HEADER ; 4/1/08 4:29pm
;;5.0; INPATIENT MEDICATIONS ;**8,20,85,95,203**;16 DEC 97;Build 13
;
; Reference to ^PS(55 supported by DBIA #2191.
;
ENTRY(DFN,PSJOPC,PG,PSJNARC,PSJTEAM,PSJY2K) ;
;DFN=patient internal entry number
;PSJOPC=a code showing what type of option is printing the header
;PG=page number
;PSJNARC=code telling whether or not to print narrative
;PSJTEAM=code telling whether or not to print team
;PSJY2K=code telling whether or not to print 4 digit year
STUFF ;
N %,ALFLG,GONE,HDT,KKA,LEN,LENCHK,PSGALG,PSGADR,PSGDT,PSGVWA,PSJPAD,PSJPAGE,PSJPDD,PSJPDOB,PSJPDX,PSJPHT,PSJPHTD,PSJPPID,PSJPR,PSJPRB,PSJPSEX,PSJPTD,PSJPWD,PSJPWDN,PSJPWT,PSJWTD,RB,SI,TEAM,VA,VA200,VADM,VAIN,VAIP,WCNT,WRD,X
;
;PPAGE=the page of the individual we are now printing. This is needed to keep track of how we print the Allergy/ADR info
;PSJNEW is set at the top of all options which call this header, if this is the first time the option has called the routine, PSJNEW will exist
;
I $D(PSJNEW) S PSGPTMP=0,PPAGE=1 K PSJNEW
S PSGP=DFN S:PSGP=$G(PSGPTMP) PPAGE=PPAGE+1 I PSGP'=$G(PSGPTMP) S PSGPTMP=PSGP,PPAGE=1
D NOW^%DTC S PSGDT=%,HDT=$$ENDTC^PSGMI(PSGDT)
S VA200=1 D INP^VADPT
I VAIN(4) S PSJPWD=+VAIN(4),PSJPWDN=$P(VAIN(4),"^",2),(PSJPRB,RB)=VAIN(5),PSJPAD=+VAIN(7),PSJPDX=VAIN(9),PSJPDD="",PSJPTD=$S($D(^PS(55,DFN,5.1)):$P(^(5.1),"^",4),1:"")
I 'VAIN(4) S VAIP("D")="L" D IN5^VADPT S PSJPWD=+VAIP(5),PSJPWDN=$P(VAIP(5),"^",2),(PSJPRB,RB)=$P(VAIP(6),"^",2),PSJPAD=+VAIP(13,1),PSJPDX=VAIP(9) D
.S PSGID=+VAIP(3),X=+VAIP(4)=12!(+VAIP(4)=38),PSJPTD="",PSJPDD=PSGID_"^"_$$ENDTC^PSGMI(PSGID) S:X PSJPDD=PSJPDD_"^1"
D DEM^VADPT,HTWT^PSJAC(DFN)
S PSGP(0)=VADM(1),PSJPDOB=+VADM(3),PSJPAGE=VADM(4),PSJPSEX=$S(VADM(5)]"":VADM(5),1:"?^____"),PSJPPID=VA("PID")
F X="PSJPAD","PSJPDOB","PSJPTD" I $G(@X) S $P(@X,"^",2)=$S($D(PSJY2K):$$ENDTC2^PSGMI(+@X),1:$$ENDTC^PSGMI(+@X))
ENHEAD ; print new page, name, ssn, dob, and ward
I $D(ENGET) S RB=$S($G(PSJPRB)]"":PSJPRB,1:"* NF *")
S SLS="",$P(SLS," -",15)=""
;* I PSJOPC]"" W:$Y @IOF W ! W:PSJOPC="ALL" ?16,"I N P A T I E N T M E D I C A T I O N S" W:PSJOPC="UD" ?19,"U N I T D O S E P R O F I L E" W:PSJOPC="IV" !,?19,"I V P A T I E N T P R O F I L E" W ?64,HDT,!,SLS,SLS,$E(SLS,1,24),!
I PSJOPC]"" D
. W:$Y @IOF
. W ! W:PSJOPC="ALL" ?16,"I N P A T I E N T M E D I C A T I O N S" W:PSJOPC="UD" ?19,"U N I T D O S E P R O F I L E" W:PSJOPC="IV" !,?19,"I V P A T I E N T P R O F I L E" W ?64,HDT
. NEW X S X=$$SITE^PSGMMAR2(80)
. W !?+X,$P(X,U,2),!,SLS,SLS,$E(SLS,1,24),!
W ?1,$P(PSGP(0),"^"),?34," ",$S('PSJPDD:"",$G(PSJIVOF):"",1:"Last "),"Ward: ",$S(PSJPDD&($G(PSJIVOF)):"OUTPATIENT",PSJPWDN]"":PSJPWDN,1:"* NF *") W:$D(PSJPR) ?75-$L(PG),"Pg: ",PG-$D(PSGVWA)
W !?4,"PID: ",PSJPPID W:'PSJPDD ?26 W:PSJPDD ?21,"Last " W "Room-Bed: ",$S(RB="":"* NF *",1:RB),?53,"Ht(cm): ",?61 W:PSJPHT["_" PSJPHT W:PSJPHT'["_" $J(PSJPHT,6,2) W ?68,PSJPHTD
W !?4,"DOB: ",$S($D(PSJY2K):$E($P(PSJPDOB,"^",2),1,10),1:$E($P(PSJPDOB,"^",2),1,8))_" ("_PSJPAGE_")"
I (PSJTEAM=1)&(RB]"") S TEAM=$S($O(^PS(57.7,"AWRT",$G(PSJPWD),$G(RB),0)):$O(^(0)),1:"") S:TEAM]"" TEAM=$G(^PS(57.7,$G(PSJPWD),1,TEAM,0))
I $D(TEAM) W ?30,"Team: ",$S(TEAM]"":TEAM,1:"* NF *")
W ?53,"Wt(kg): ",?61 W:PSJPWT["_" PSJPWT W:PSJPWT'["_" $J(PSJPWT,6,2) W ?68,PSJPWTD
W !?4,"Sex: ",$P(PSJPSEX,"^",2),?'PSJPDD*5+46,$S(PSJPDD:"Last ",1:""),"Admitted: ",$S($D(PSJY2K):$E($P(PSJPAD,"^",2),1,10),1:$E($P(PSJPAD,"^",2),1,8))
W !?5,"Dx: ",$S(PSJPDX]"":PSJPDX,1:"* NF *") S X=$S(PSJPDD:PSJPDD,1:$G(PSJPTD)) I X W ?PSJPDD>0*6+43,$S(PSJPDD:"Discharged: ",1:"Last transferred: "),$S($D(PSJY2K):$E($P(X,"^",2),1,10),1:$E($P(X,"^",2),1,8))
I PSJNARC=1 W !?1,"Pharmacy Narrative: " S WCNT=1,SI=$G(^PS(55,DFN,1)) W:SI=""&($E(IOST)="P") " ____________________" I SI]"" D
.S LENCHK=0,LEN=$L(SI)
.F S WRD=$P(SI," ",WCNT) Q:$L(WRD)=0&(LENCHK'<LEN) S WCNT=WCNT+1 W:$X+$L(WRD)>79 !,?21 W " ",WRD S LENCHK=LENCHK+$L(WRD)+1
S PSGP=DFN,ALFLG=0 D ATS^PSJMUTL(68,68,2)
W !?1,"Allergies: " D:PSGALG+PSGVALG+PSGADR+PSGVADR=0 NONE I PSGALG+PSGVALG+PSGADR+PSGVADR>0 D ALG,ADR I ALFLG D
.W "See patient's first ",$S($E(IOST)="C":"screen",1:"page")," for Allergies/Adverse Reactions"
I $D(^PS(55,DFN,5.1)),$P(^(5.1),"^",7) S X=$P(^(5.1),"^",10),X="* ALL "_$S($P(^(5.1),"^",7)=1:"UNIT DOSE ",1:"")_"ORDERS PLACED ON HOLD "_$E("(",X]"")_X_$E(")",X]"")_" *" W $C(7),!!?80-$L(X)\2,X
Q
NONE ;
;W:$E(IOST)="P" "______________________________" W !?7,"ADR: " W:$E(IOST)="P" "____________________________________"
W "No Allergy Assessment" W !?7,"ADR: " W:$E(IOST)="P" "____________________________________"
Q
ALG ;
I PPAGE>1&((PSGALG'<68)!(PSGADR'<63)) S ALFLG=1 Q
I PSGVALG(1)["NKA",(PSGALG(1)["NKA") S PSGALG(1)=""
I PSGALG=20,(PSGALG(1)["__________") D
. I PSGVADR=20,(PSGVADR(1)["__________") S PSGALG(1)="" S:PSGVALG(1)["__________" PSGVALG(1)="No Allergy Assessment"
S KKA=0 F S KKA=$O(PSGVALG(KKA)) Q:'KKA W:KKA>1 !?12 W PSGVALG(KKA)
I PSGALG(1)]"",(PSGALG(1)'["__________") W !," NV Aller.: " D
. S KKA=0 F S KKA=$O(PSGALG(KKA)) Q:'KKA W:KKA>1 !?12 W PSGALG(KKA)
Q
ADR ;
Q:ALFLG
W !?7,"ADR: "
I PSGVADR(1)["NKA",(PSGADR(1)["NKA") S PSGADR(1)=""
I PSGADR=20,(PSGADR(1)["__________") S PSGADR(1)=""
S KKA=0 F S KKA=$O(PSGVADR(KKA)) Q:'KKA W:KKA>1 !?12 W PSGVADR(KKA)
I PSGADR(1)]"" W !?4,"NV ADR: " D
. S KKA=0 F S KKA=$O(PSGADR(KKA)) Q:'KKA W:KKA>1 !?12 W PSGADR(KKA)
Q
PSJHEAD ;BIR/KKA-PROFILE HEADER ; 4/1/08 4:29pm
+1 ;;5.0; INPATIENT MEDICATIONS ;**8,20,85,95,203**;16 DEC 97;Build 13
+2 ;
+3 ; Reference to ^PS(55 supported by DBIA #2191.
+4 ;
ENTRY(DFN,PSJOPC,PG,PSJNARC,PSJTEAM,PSJY2K) ;
+1 ;DFN=patient internal entry number
+2 ;PSJOPC=a code showing what type of option is printing the header
+3 ;PG=page number
+4 ;PSJNARC=code telling whether or not to print narrative
+5 ;PSJTEAM=code telling whether or not to print team
+6 ;PSJY2K=code telling whether or not to print 4 digit year
STUFF ;
+1 NEW %,ALFLG,GONE,HDT,KKA,LEN,LENCHK,PSGALG,PSGADR,PSGDT,PSGVWA,PSJPAD,PSJPAGE,PSJPDD,PSJPDOB,PSJPDX,PSJPHT,PSJPHTD,PSJPPID,PSJPR,PSJPRB,PSJPSEX,PSJPTD,PSJPWD,PSJPWDN,PSJPWT,PSJWTD,RB,SI,TEAM,VA,VA200,VADM,VAIN,VAIP,WCNT,WRD,X
+2 ;
+3 ;PPAGE=the page of the individual we are now printing. This is needed to keep track of how we print the Allergy/ADR info
+4 ;PSJNEW is set at the top of all options which call this header, if this is the first time the option has called the routine, PSJNEW will exist
+5 ;
+6 IF $DATA(PSJNEW)
SET PSGPTMP=0
SET PPAGE=1
KILL PSJNEW
+7 SET PSGP=DFN
IF PSGP=$GET(PSGPTMP)
SET PPAGE=PPAGE+1
IF PSGP'=$GET(PSGPTMP)
SET PSGPTMP=PSGP
SET PPAGE=1
+8 DO NOW^%DTC
SET PSGDT=%
SET HDT=$$ENDTC^PSGMI(PSGDT)
+9 SET VA200=1
DO INP^VADPT
+10 IF VAIN(4)
SET PSJPWD=+VAIN(4)
SET PSJPWDN=$PIECE(VAIN(4),"^",2)
SET (PSJPRB,RB)=VAIN(5)
SET PSJPAD=+VAIN(7)
SET PSJPDX=VAIN(9)
SET PSJPDD=""
SET PSJPTD=$SELECT($DATA(^PS(55,DFN,5.1)):$PIECE(^(5.1),"^",4),1:"")
+11 IF 'VAIN(4)
SET VAIP("D")="L"
DO IN5^VADPT
SET PSJPWD=+VAIP(5)
SET PSJPWDN=$PIECE(VAIP(5),"^",2)
SET (PSJPRB,RB)=$PIECE(VAIP(6),"^",2)
SET PSJPAD=+VAIP(13,1)
SET PSJPDX=VAIP(9)
Begin DoDot:1
+12 SET PSGID=+VAIP(3)
SET X=+VAIP(4)=12!(+VAIP(4)=38)
SET PSJPTD=""
SET PSJPDD=PSGID_"^"_$$ENDTC^PSGMI(PSGID)
IF X
SET PSJPDD=PSJPDD_"^1"
End DoDot:1
+13 DO DEM^VADPT
DO HTWT^PSJAC(DFN)
+14 SET PSGP(0)=VADM(1)
SET PSJPDOB=+VADM(3)
SET PSJPAGE=VADM(4)
SET PSJPSEX=$SELECT(VADM(5)]"":VADM(5),1:"?^____")
SET PSJPPID=VA("PID")
+15 FOR X="PSJPAD","PSJPDOB","PSJPTD"
IF $GET(@X)
SET $PIECE(@X,"^",2)=$SELECT($DATA(PSJY2K):$$ENDTC2^PSGMI(+@X),1:$$ENDTC^PSGMI(+@X))
ENHEAD ; print new page, name, ssn, dob, and ward
+1 IF $DATA(ENGET)
SET RB=$SELECT($GET(PSJPRB)]"":PSJPRB,1:"* NF *")
+2 SET SLS=""
SET $PIECE(SLS," -",15)=""
+3 ;* I PSJOPC]"" W:$Y @IOF W ! W:PSJOPC="ALL" ?16,"I N P A T I E N T M E D I C A T I O N S" W:PSJOPC="UD" ?19,"U N I T D O S E P R O F I L E" W:PSJOPC="IV" !,?19,"I V P A T I E N T P R O F I L E" W ?64,HDT,!,SLS,SLS,$E(SLS,1,24),!
+4 IF PSJOPC]""
Begin DoDot:1
+5 IF $Y
WRITE @IOF
+6 WRITE !
IF PSJOPC="ALL"
WRITE ?16,"I N P A T I E N T M E D I C A T I O N S"
IF PSJOPC="UD"
WRITE ?19,"U N I T D O S E P R O F I L E"
IF PSJOPC="IV"
WRITE !,?19,"I V P A T I E N T P R O F I L E"
WRITE ?64,HDT
+7 NEW X
SET X=$$SITE^PSGMMAR2(80)
+8 WRITE !?+X,$PIECE(X,U,2),!,SLS,SLS,$EXTRACT(SLS,1,24),!
End DoDot:1
+9 WRITE ?1,$PIECE(PSGP(0),"^"),?34," ",$SELECT('PSJPDD:"",$GET(PSJIVOF):"",1:"Last "),"Ward: ",$SELECT(PSJPDD&($GET(PSJIVOF)):"OUTPATIENT",PSJPWDN]"":PSJPWDN,1:"* NF *")
IF $DATA(PSJPR)
WRITE ?75-$LENGTH(PG),"Pg: ",PG-$DATA(PSGVWA)
+10 WRITE !?4,"PID: ",PSJPPID
IF 'PSJPDD
WRITE ?26
IF PSJPDD
WRITE ?21,"Last "
WRITE "Room-Bed: ",$SELECT(RB="":"* NF *",1:RB),?53,"Ht(cm): ",?61
IF PSJPHT["_"
WRITE PSJPHT
IF PSJPHT'["_"
WRITE $JUSTIFY(PSJPHT,6,2)
WRITE ?68,PSJPHTD
+11 WRITE !?4,"DOB: ",$SELECT($DATA(PSJY2K):$EXTRACT($PIECE(PSJPDOB,"^",2),1,10),1:$EXTRACT($PIECE(PSJPDOB,"^",2),1,8))_" ("_PSJPAGE_")"
+12 IF (PSJTEAM=1)&(RB]"")
SET TEAM=$SELECT($ORDER(^PS(57.7,"AWRT",$GET(PSJPWD),$GET(RB),0)):$ORDER(^(0)),1:"")
IF TEAM]""
SET TEAM=$GET(^PS(57.7,$GET(PSJPWD),1,TEAM,0))
+13 IF $DATA(TEAM)
WRITE ?30,"Team: ",$SELECT(TEAM]"":TEAM,1:"* NF *")
+14 WRITE ?53,"Wt(kg): ",?61
IF PSJPWT["_"
WRITE PSJPWT
IF PSJPWT'["_"
WRITE $JUSTIFY(PSJPWT,6,2)
WRITE ?68,PSJPWTD
+15 WRITE !?4,"Sex: ",$PIECE(PSJPSEX,"^",2),?'PSJPDD*5+46,$SELECT(PSJPDD:"Last ",1:""),"Admitted: ",$SELECT($DATA(PSJY2K):$EXTRACT($PIECE(PSJPAD,"^",2),1,10),1:$EXTRACT($PIECE(PSJPAD,"^",2),1,8))
+16 WRITE !?5,"Dx: ",$SELECT(PSJPDX]"":PSJPDX,1:"* NF *")
SET X=$SELECT(PSJPDD:PSJPDD,1:$GET(PSJPTD))
IF X
WRITE ?PSJPDD>0*6+43,$SELECT(PSJPDD:"Discharged: ",1:"Last transferred: "),$SELECT($DATA(PSJY2K):$EXTRACT($PIECE(X,"^",2),1,10),1:$EXTRACT($PIECE(X,"^",2),1,8))
+17 IF PSJNARC=1
WRITE !?1,"Pharmacy Narrative: "
SET WCNT=1
SET SI=$GET(^PS(55,DFN,1))
IF SI=""&($EXTRACT(IOST)="P")
WRITE " ____________________"
IF SI]""
Begin DoDot:1
+18 SET LENCHK=0
SET LEN=$LENGTH(SI)
+19 FOR
SET WRD=$PIECE(SI," ",WCNT)
IF $LENGTH(WRD)=0&(LENCHK'<LEN)
QUIT
SET WCNT=WCNT+1
IF $X+$LENGTH(WRD)>79
WRITE !,?21
WRITE " ",WRD
SET LENCHK=LENCHK+$LENGTH(WRD)+1
End DoDot:1
+20 SET PSGP=DFN
SET ALFLG=0
DO ATS^PSJMUTL(68,68,2)
+21 WRITE !?1,"Allergies: "
IF PSGALG+PSGVALG+PSGADR+PSGVADR=0
DO NONE
IF PSGALG+PSGVALG+PSGADR+PSGVADR>0
DO ALG
DO ADR
IF ALFLG
Begin DoDot:1
+22 WRITE "See patient's first ",$SELECT($EXTRACT(IOST)="C":"screen",1:"page")," for Allergies/Adverse Reactions"
End DoDot:1
+23 IF $DATA(^PS(55,DFN,5.1))
IF $PIECE(^(5.1),"^",7)
SET X=$PIECE(^(5.1),"^",10)
SET X="* ALL "_$SELECT($PIECE(^(5.1),"^",7)=1:"UNIT DOSE ",1:"")_"ORDERS PLACED ON HOLD "_$EXTRACT("(",X]"")_X_$EXTRACT(")",X]"")_" *"
WRITE $CHAR(7),!!?80-$LENGTH(X)\2,X
+24 QUIT
NONE ;
+1 ;W:$E(IOST)="P" "______________________________" W !?7,"ADR: " W:$E(IOST)="P" "____________________________________"
+2 WRITE "No Allergy Assessment"
WRITE !?7,"ADR: "
IF $EXTRACT(IOST)="P"
WRITE "____________________________________"
+3 QUIT
ALG ;
+1 IF PPAGE>1&((PSGALG'<68)!(PSGADR'<63))
SET ALFLG=1
QUIT
+2 IF PSGVALG(1)["NKA"
IF (PSGALG(1)["NKA")
SET PSGALG(1)=""
+3 IF PSGALG=20
IF (PSGALG(1)["__________")
Begin DoDot:1
+4 IF PSGVADR=20
IF (PSGVADR(1)["__________")
SET PSGALG(1)=""
IF PSGVALG(1)["__________"
SET PSGVALG(1)="No Allergy Assessment"
End DoDot:1
+5 SET KKA=0
FOR
SET KKA=$ORDER(PSGVALG(KKA))
IF 'KKA
QUIT
IF KKA>1
WRITE !?12
WRITE PSGVALG(KKA)
+6 IF PSGALG(1)]""
IF (PSGALG(1)'["__________")
WRITE !," NV Aller.: "
Begin DoDot:1
+7 SET KKA=0
FOR
SET KKA=$ORDER(PSGALG(KKA))
IF 'KKA
QUIT
IF KKA>1
WRITE !?12
WRITE PSGALG(KKA)
End DoDot:1
+8 QUIT
ADR ;
+1 IF ALFLG
QUIT
+2 WRITE !?7,"ADR: "
+3 IF PSGVADR(1)["NKA"
IF (PSGADR(1)["NKA")
SET PSGADR(1)=""
+4 IF PSGADR=20
IF (PSGADR(1)["__________")
SET PSGADR(1)=""
+5 SET KKA=0
FOR
SET KKA=$ORDER(PSGVADR(KKA))
IF 'KKA
QUIT
IF KKA>1
WRITE !?12
WRITE PSGVADR(KKA)
+6 IF PSGADR(1)]""
WRITE !?4,"NV ADR: "
Begin DoDot:1
+7 SET KKA=0
FOR
SET KKA=$ORDER(PSGADR(KKA))
IF 'KKA
QUIT
IF KKA>1
WRITE !?12
WRITE PSGADR(KKA)
End DoDot:1
+8 QUIT
