PSGCAPP0 ;BIR/CML3-PRINT DATA FOR ACTION PROFILE CONT. ;29-May-2012 14:26;PLS
;;5.0; INPATIENT MEDICATIONS ;**8,20,85,169,203,1015**;16 DEC 97;Build 62
;
; Modified - IHS/CIA/PLS - 08/29/04 - H1+4
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
;IHS/CIA/PLS - 08/29/04 - Removed references to VA FORM
;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:$Y @IOF W !?26,"UNIT DOSE ACTION PROFILE #2",?62,PSGPDT,!?+PSGVAMC,$P(PSGVAMC,U,2),!?23,"(Continuation of FORM)",?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
;
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
PSGCAPP0 ;BIR/CML3-PRINT DATA FOR ACTION PROFILE CONT. ;29-May-2012 14:26;PLS
+1 ;;5.0; INPATIENT MEDICATIONS ;**8,20,85,169,203,1015**;16 DEC 97;Build 62
+2 ;
+3 ; Modified - IHS/CIA/PLS - 08/29/04 - H1+4
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 ;IHS/CIA/PLS - 08/29/04 - Removed references to VA FORM
+5 ;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
+6 IF $Y
WRITE @IOF
WRITE !?26,"UNIT DOSE ACTION PROFILE #2",?62,PSGPDT,!?+PSGVAMC,$PIECE(PSGVAMC,U,2),!?23,"(Continuation of FORM)",?72,"Page: 1",!,LINE
+7 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
+8 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
+9 WRITE !?4,"DOB: "_PDOB_" ("_PAGE_")",?53,"Wt(kg): "_WT," ",WTD
+10 WRITE !?4,"Sex: "_PSEX,?51,"Admitted: "_AD
+11 ;
+12 WRITE !?5,"Dx: "_PI
IF TD
WRITE ?43,"Last Transferred: "_TD
+13 ;
+14 SET PSGP=$PIECE(PN,U,2)
IF PSGP=$GET(PSGPTMP)
SET PPAGE=PPAGE+1
IF PSGP'=$GET(PSGPTMP)
SET PSGPTMP=PSGP
SET PPAGE=1
+15 SET ALFLG=0
DO ATS^PSJMUTL(68,68,2)
+16 ; PSJ*5*169 Make the allergy/ADR algorithm consistent with one used in PSJHEAD for AP-1 report.
+17 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
+18 WRITE "See patient's first ",$SELECT($EXTRACT(IOST)="C":"screen",1:"page")," for Allergies/Adverse Reactions"
End DoDot:1
+19 WRITE !,LINE,!,"No. Action",?16,"Drug",?46,"ST Start Stop Status/Info",!,ALN
+20 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
