- PSJHEAD ;BIR/KKA-PROFILE HEADER ; 4/1/08 4:29pm
- ;;5.0;INPATIENT MEDICATIONS;**8,20,85,95,203,260,256,387**;16 DEC 97;Build 1
- ;
- ; Reference to ^PS(55 supported by DBIA #2191.
- ;External reference to $$BSA^PSSDSAPI supported by DBIA 5425.
- ;
- 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,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))
- ;
- ; Display CrCl/BSA - show serum creatinine if CrCl can't be calculated
- S PSJBSA=$$BSA^PSSDSAPI(DFN),PSJBSA=$P(PSJBSA,"^",3),PSJBSA=$S(PSJBSA'>0:"_________",1:$J(PSJBSA,4,2))
- S RSLT=$$CRCL^PSJLMHED(DFN)
- ; Display format of CrCL and Creatinine results updated - PSJ*5.0*387
- I ($P($G(RSLT),"^",2)["Not Found")&($P($G(RSLT),"^",3)<.01) S ZDSPL=" CrCL: "_$P(RSLT,"^",2)_" (CREAT: Not Found)"
- I ($P($G(RSLT),"^",2)["Not Found")&($P($G(RSLT),"^",3)>=.01) S ZDSPL=" CrCL: "_$P(RSLT,"^",2)_" (CREAT: "_$P($G(RSLT),"^",3)_"mg/dL "_$P($G(RSLT),"^")_")"
- I ($P($G(RSLT),"^",2)'["Not Found")&($P($G(RSLT),"^",3)<.01) S ZDSPL=" CrCL: "_$P(RSLT,"^",2)_" (CREAT: Not Found)"
- I ($P($G(RSLT),"^",2)'["Not Found")&($P($G(RSLT),"^",3)>=.01) S ZDSPL=" CrCL: "_$P(RSLT,"^",2)_"(est.)"_" (CREAT: "_$P($G(RSLT),"^",3)_"mg/dL "_$P($G(RSLT),"^")_")"
- W !?2,$G(ZDSPL),?51,"BSA (m2): ",$G(PSJBSA) K ZDSPL,RSLT,PSJBSA
- ;
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJHEAD 6474 printed Feb 18, 2025@23:33:15 Page 2
- PSJHEAD ;BIR/KKA-PROFILE HEADER ; 4/1/08 4:29pm
- +1 ;;5.0;INPATIENT MEDICATIONS;**8,20,85,95,203,260,256,387**;16 DEC 97;Build 1
- +2 ;
- +3 ; Reference to ^PS(55 supported by DBIA #2191.
- +4 ;External reference to $$BSA^PSSDSAPI supported by DBIA 5425.
- +5 ;
- 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,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 ;
- +18 ; Display CrCl/BSA - show serum creatinine if CrCl can't be calculated
- +19 SET PSJBSA=$$BSA^PSSDSAPI(DFN)
- SET PSJBSA=$PIECE(PSJBSA,"^",3)
- SET PSJBSA=$SELECT(PSJBSA'>0:"_________",1:$JUSTIFY(PSJBSA,4,2))
- +20 SET RSLT=$$CRCL^PSJLMHED(DFN)
- +21 ; Display format of CrCL and Creatinine results updated - PSJ*5.0*387
- +22 IF ($PIECE($GET(RSLT),"^",2)["Not Found")&($PIECE($GET(RSLT),"^",3)<.01)
- SET ZDSPL=" CrCL: "_$PIECE(RSLT,"^",2)_" (CREAT: Not Found)"
- +23 IF ($PIECE($GET(RSLT),"^",2)["Not Found")&($PIECE($GET(RSLT),"^",3)>=.01)
- SET ZDSPL=" CrCL: "_$PIECE(RSLT,"^",2)_" (CREAT: "_$PIECE($GET(RSLT),"^",3)_"mg/dL "_$PIECE($GET(RSLT),"^")_")"
- +24 IF ($PIECE($GET(RSLT),"^",2)'["Not Found")&($PIECE($GET(RSLT),"^",3)<.01)
- SET ZDSPL=" CrCL: "_$PIECE(RSLT,"^",2)_" (CREAT: Not Found)"
- +25 IF ($PIECE($GET(RSLT),"^",2)'["Not Found")&($PIECE($GET(RSLT),"^",3)>=.01)
- SET ZDSPL=" CrCL: "_$PIECE(RSLT,"^",2)_"(est.)"_" (CREAT: "_$PIECE($GET(RSLT),"^",3)_"mg/dL "_$PIECE($GET(RSLT),"^")_")"
- +26 WRITE !?2,$GET(ZDSPL),?51,"BSA (m2): ",$GET(PSJBSA)
- KILL ZDSPL,RSLT,PSJBSA
- +27 ;
- +28 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
- +29 SET LENCHK=0
- SET LEN=$LENGTH(SI)
- +30 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
- +31 SET PSGP=DFN
- SET ALFLG=0
- DO ATS^PSJMUTL(68,68,2)
- +32 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
- +33 WRITE "See patient's first ",$SELECT($EXTRACT(IOST)="C":"screen",1:"page")," for Allergies/Adverse Reactions"
- End DoDot:1
- +34 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
- +35 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