- PSGCAPP0 ;BIR/CML3-PRINT DATA FOR ACTION PROFILE CONT. ; 4/1/08 3:05pm
- ;;5.0;INPATIENT MEDICATIONS;**8,20,85,169,203,256,387**;16 DEC 97;Build 1
- ; Reference to BSA^PSSDSAPI supported by DBIA #5425
- H1 ; first header for patient
- I $E(IOST,1)="C" K DIR S DIR(0)="E" D ^DIR K DIR S:$D(DTOUT)!$D(DUOUT) PSJDLW=1 I $D(DTOUT)!$D(DUOUT) Q
- S (N,DF)=0,PSEX=$P(PI,"^"),PDOB=$P(PI,"^",2),PID=$P(PI,"^",3),RB=$P(PI,"^",5),AD=$P(PI,"^",6),TD=$P(PI,"^",7),WT=$P(PI,"^",8),WTD=$P(PI,"^",9),HT=$P(PI,"^",10),HTD=$P(PI,"^",11),PPN=$P(PI,"^",12),PI=$P(PI,"^",4),PSGP=$P(PN,"^",2)
- S PAGE=$P(PDOB,";",2),PDOB=$P(PDOB,";"),PG=1
- W:$Y @IOF W !?26,"UNIT DOSE ACTION PROFILE #2",?62,PSGPDT,!?+PSGVAMC,$P(PSGVAMC,U,2),!?23,"(Continuation of VA FORM 10-1158)",?72,"Page: 1",!,LINE
- W !," A new order must be written for any new medication or to make any changes",!," in dosage or directions on an existing order.",!,LINE
- W !?32-(PSGAPS="P"*13),$S(PSGAPS="T":"Team: ",1:"Treating Provider: "),PS1,!?1,PPN,?32,"Ward: "_WD,!?4,"PID: "_PID W:'PSJPDD ?28 W:PSJPDD ?23,"Last " W "Room-Bed: ",RB,?53,"Ht(cm): ",HT," ",HTD
- W !?4,"DOB: "_PDOB_" ("_PAGE_")",?53,"Wt(kg): "_WT," ",WTD
- W !?4,"Sex: "_PSEX,?51,"Admitted: "_AD
- ;
- W !?5,"Dx: "_PI W:TD ?43,"Last Transferred: "_TD
- ; Display 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
- ;
- S PSGP=$P(PN,U,2) S:PSGP=$G(PSGPTMP) PPAGE=PPAGE+1 I PSGP'=$G(PSGPTMP) S PSGPTMP=PSGP,PPAGE=1
- S ALFLG=0 D ATS^PSJMUTL(68,68,2)
- ; PSJ*5*169 Make the allergy/ADR algorithm consistent with one used in PSJHEAD for AP-1 report.
- W !?1,"Allergies: " D:PSGALG+PSGVALG+PSGADR+PSGVADR=0 NONE I PSGALG+PSGVALG+PSGADR+PSGVADR>0 D ALG^PSJHEAD,ADR^PSJHEAD I ALFLG D
- .W "See patient's first ",$S($E(IOST)="C":"screen",1:"page")," for Allergies/Adverse Reactions"
- W !,LINE,!,"No. Action",?16,"Drug",?46,"ST Start Stop Status/Info",!,ALN
- 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 ; NOT USED ANYMORE, ALG^PSJHEAD
- I PPAGE>1&((PSGALG'<68)!(PSGADR'<63)) S ALFLG=1 Q
- S KKA=0 F S KKA=$O(PSGALG(KKA)) Q:'KKA W:KKA>1 !?12 W PSGALG(KKA)
- Q
- ADR ; NOT USED ANYMORE, ADR^PSJHEAD
- Q:ALFLG
- W !?7,"ADR: "
- S KKA=0 F S KKA=$O(PSGADR(KKA)) Q:'KKA W:KKA>1 !?12 W PSGADR(KKA)
- Q
- ;
- ENRCT ;
- N DFN,GMRA,GMRAL,RCT,X S DFN=PSGP,GMRA="0^0^111" D ^GMRADPT
- S X=0 F S X=$O(GMRAL(X)) Q:'X I $P(GMRAL(X),U,2)]"" S RCT($P(GMRAL(X),U,2))=""
- ;W:'$D(RCT) "____________________" S RCT="" F X=1:1 S RCT=$O(RCT(RCT)) Q:RCT="" W:X>1 "," W:$X+$L(RCT)>77 ! W " ",RCT
- W:'$D(RCT) "No Allergy Assessment" S RCT="" F X=1:1 S RCT=$O(RCT(RCT)) Q:RCT="" W:X>1 "," W:$X+$L(RCT)>77 ! W " ",RCT
- W !,LINE,!," No.",?11,"Drug",?46,"ST Start Stop Status/Info",!,ALN
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGCAPP0 3714 printed Feb 18, 2025@23:27:20 Page 2
- PSGCAPP0 ;BIR/CML3-PRINT DATA FOR ACTION PROFILE CONT. ; 4/1/08 3:05pm
- +1 ;;5.0;INPATIENT MEDICATIONS;**8,20,85,169,203,256,387**;16 DEC 97;Build 1
- +2 ; Reference to BSA^PSSDSAPI supported by DBIA #5425
- H1 ; first header for patient
- +1 IF $EXTRACT(IOST,1)="C"
- KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- if $DATA(DTOUT)!$DATA(DUOUT)
- SET PSJDLW=1
- IF $DATA(DTOUT)!$DATA(DUOUT)
- QUIT
- +2 SET (N,DF)=0
- SET PSEX=$PIECE(PI,"^")
- SET PDOB=$PIECE(PI,"^",2)
- SET PID=$PIECE(PI,"^",3)
- SET RB=$PIECE(PI,"^",5)
- SET AD=$PIECE(PI,"^",6)
- SET TD=$PIECE(PI,"^",7)
- SET WT=$PIECE(PI,"^",8)
- SET WTD=$PIECE(PI,"^",9)
- SET HT=$PIECE(PI,"^",10)
- SET HTD=$PIECE(PI,"^",11)
- SET PPN=$PIECE(PI,"^",12)
- SET PI=$PIECE(PI,"^",4)
- SET PSGP=$PIECE(PN,"^",2)
- +3 SET PAGE=$PIECE(PDOB,";",2)
- SET PDOB=$PIECE(PDOB,";")
- SET PG=1
- +4 if $Y
- WRITE @IOF
- WRITE !?26,"UNIT DOSE ACTION PROFILE #2",?62,PSGPDT,!?+PSGVAMC,$PIECE(PSGVAMC,U,2),!?23,"(Continuation of VA FORM 10-1158)",?72,"Page: 1",!,LINE
- +5 WRITE !," A new order must be written for any new medication or to make any changes",!," in dosage or directions on an existing order.",!,LINE
- +6 WRITE !?32-(PSGAPS="P"*13),$SELECT(PSGAPS="T":"Team: ",1:"Treating Provider: "),PS1,!?1,PPN,?32,"Ward: "_WD,!?4,"PID: "_PID
- if 'PSJPDD
- WRITE ?28
- if PSJPDD
- WRITE ?23,"Last "
- WRITE "Room-Bed: ",RB,?53,"Ht(cm): ",HT," ",HTD
- +7 WRITE !?4,"DOB: "_PDOB_" ("_PAGE_")",?53,"Wt(kg): "_WT," ",WTD
- +8 WRITE !?4,"Sex: "_PSEX,?51,"Admitted: "_AD
- +9 ;
- +10 WRITE !?5,"Dx: "_PI
- if TD
- WRITE ?43,"Last Transferred: "_TD
- +11 ; Display serum creatinine if CrCl can't be calculated
- +12 SET PSJBSA=$$BSA^PSSDSAPI(DFN)
- SET PSJBSA=$PIECE(PSJBSA,"^",3)
- SET PSJBSA=$SELECT(PSJBSA'>0:"_________",1:$JUSTIFY(PSJBSA,4,2))
- +13 SET RSLT=$$CRCL^PSJLMHED(DFN)
- +14 ; Display format of CrCL and Creatinine results updated - PSJ*5.0*387
- +15 IF ($PIECE($GET(RSLT),"^",2)["Not Found")&($PIECE($GET(RSLT),"^",3)<.01)
- SET ZDSPL=" CrCL: "_$PIECE(RSLT,"^",2)_" (CREAT: Not Found)"
- +16 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),"^")_")"
- +17 IF ($PIECE($GET(RSLT),"^",2)'["Not Found")&($PIECE($GET(RSLT),"^",3)<.01)
- SET ZDSPL=" CrCL: "_$PIECE(RSLT,"^",2)_" (CREAT: Not Found)"
- +18 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),"^")_")"
- +19 WRITE !?2,$GET(ZDSPL),?51,"BSA (m2): ",$GET(PSJBSA)
- KILL ZDSPL,RSLT,PSJBSA
- +20 ;
- +21 SET PSGP=$PIECE(PN,U,2)
- if PSGP=$GET(PSGPTMP)
- SET PPAGE=PPAGE+1
- IF PSGP'=$GET(PSGPTMP)
- SET PSGPTMP=PSGP
- SET PPAGE=1
- +22 SET ALFLG=0
- DO ATS^PSJMUTL(68,68,2)
- +23 ; PSJ*5*169 Make the allergy/ADR algorithm consistent with one used in PSJHEAD for AP-1 report.
- +24 WRITE !?1,"Allergies: "
- if PSGALG+PSGVALG+PSGADR+PSGVADR=0
- DO NONE
- IF PSGALG+PSGVALG+PSGADR+PSGVADR>0
- DO ALG^PSJHEAD
- DO ADR^PSJHEAD
- IF ALFLG
- Begin DoDot:1
- +25 WRITE "See patient's first ",$SELECT($EXTRACT(IOST)="C":"screen",1:"page")," for Allergies/Adverse Reactions"
- End DoDot:1
- +26 WRITE !,LINE,!,"No. Action",?16,"Drug",?46,"ST Start Stop Status/Info",!,ALN
- +27 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 ; NOT USED ANYMORE, ALG^PSJHEAD
- +1 IF PPAGE>1&((PSGALG'<68)!(PSGADR'<63))
- SET ALFLG=1
- QUIT
- +2 SET KKA=0
- FOR
- SET KKA=$ORDER(PSGALG(KKA))
- if 'KKA
- QUIT
- if KKA>1
- WRITE !?12
- WRITE PSGALG(KKA)
- +3 QUIT
- ADR ; NOT USED ANYMORE, ADR^PSJHEAD
- +1 if ALFLG
- QUIT
- +2 WRITE !?7,"ADR: "
- +3 SET KKA=0
- FOR
- SET KKA=$ORDER(PSGADR(KKA))
- if 'KKA
- QUIT
- if KKA>1
- WRITE !?12
- WRITE PSGADR(KKA)
- +4 QUIT
- +5 ;
- ENRCT ;
- +1 NEW DFN,GMRA,GMRAL,RCT,X
- SET DFN=PSGP
- SET GMRA="0^0^111"
- DO ^GMRADPT
- +2 SET X=0
- FOR
- SET X=$ORDER(GMRAL(X))
- if 'X
- QUIT
- IF $PIECE(GMRAL(X),U,2)]""
- SET RCT($PIECE(GMRAL(X),U,2))=""
- +3 ;W:'$D(RCT) "____________________" S RCT="" F X=1:1 S RCT=$O(RCT(RCT)) Q:RCT="" W:X>1 "," W:$X+$L(RCT)>77 ! W " ",RCT
- +4 if '$DATA(RCT)
- WRITE "No Allergy Assessment"
- SET RCT=""
- FOR X=1:1
- SET RCT=$ORDER(RCT(RCT))
- if RCT=""
- QUIT
- if X>1
- WRITE ","
- if $X+$LENGTH(RCT)>77
- WRITE !
- WRITE " ",RCT
- +5 WRITE !,LINE,!," No.",?11,"Drug",?46,"ST Start Stop Status/Info",!,ALN
- +6 QUIT
