PSJEXP0 ;BIR/CML3,KKA - PRINTS MEDICATION EXPIRATION NOTICES ;13 FEB 96 / 10:04 AM
;;5.0;INPATIENT MEDICATIONS ;**50,58,328**;16 DEC 97;Build 6
;
; Reference to ^PS(55 is supported by DBIA# 2191.
;
D NOW^%DTC S PSGDT=%,PSGOD=$$ENDTC^PSGMI(PSGDT) U IO
I '$D(^TMP("PSG",$J)) D G DONE
.W:IO'=(IO(0)!(IOST'["C-"))&($Y) @IOF W !!," AS OF ",PSGOD,!,"NO EXPIRED ORDERS FROM ",PSGEXPS," THROUGH ",PSGEXPF,!,"FOR ",$S(PSGSS="P":"PATIENT",PSGSS="W":"WARD",PSGSS="C":"CLINIC",PSGSS="L":"CLINIC GROUP",1:"WARD GROUP"),": ",PSJMSG,"."
S PSGPDT=PSGOD,(BLF,LINE,PSSN,Q,TM,WDN,RB,PN)="",PG=0,$P(LINE,"-",81)="" K PSJDLW
F S TM=$O(^TMP("PSG",$J,TM)) Q:TM=""!$G(PSJDLW) F S WDN=$O(^TMP("PSG",$J,TM,WDN)) Q:WDN=""!$G(PSJDLW) F S RB=$O(^TMP("PSG",$J,TM,WDN,RB)) Q:RB=""!$G(PSJDLW) D STRT1
S Q=1 D:'$G(PSJDLW) NP
;
DONE ;
W:(IO'=IO(0)!(IOST'["C-"))&($Y) @IOF K AD,BLF,DX,LINE,OPN,PSJORB,OSSN,OTM,OWDN,PAGE,PDOB,PG,PN,PRB,PSD,PSGPDT,PSSN,PST,PTM,PWDN,RCT,Q1,RB,TD,WDRG
Q
;
STRT1 ;
F S PN=$O(^TMP("PSG",$J,TM,WDN,RB,PN)) Q:PN=""!$G(PSJDLW) S ND=^(PN) D INFO F SD=0:0 S SD=$O(^TMP("PSG",$J,TM,WDN,RB,PN,SD)) Q:'SD!$G(PSJDLW) D PRT
Q
;
PRT ;
S PSD=$$ENDTC^PSGMI(SD)
F PST="C","O","OC","P","R" S DRG="" F S DRG=$O(^TMP("PSG",$J,TM,WDN,RB,PN,SD,PST,DRG)) Q:DRG=""!$G(PSJDLW) S ND=^(DRG),PSJJORD=$P(DRG,"^",2) D:$Y+6>IOSL NP I '$G(PSJDLW) D:PSJJORD'["V" WREC I PSJJORD["V" S PSJJORD=$P(PSJJORD,"V") D WRECIV
Q
;
INFO ;
S PSGP=$P(PN,"^",2),PTM=$P(ND,"^"),PWDN=$P(ND,"^",2),PRB=$P(ND,"^",3),PPN=$P(ND,"^",4) S:PPN=PSGP PPN=PPN_";DPT(" F X="PTM","PWDN","PRB" I @X="zz" S @X="*NF*"
S PSEX=$P(ND,"^",5),PDOB=$P(ND,"^",6),PSSN=$P(ND,"^",7),DX=$P(ND,"^",8),WT=$P(ND,"^",9),AD=$P(ND,"^",10),TD=$P(ND,"^",11),PAGE=$S($P(PDOB,";",2):$P(PDOB,";",2),1:"?"),PDOB=$P(PDOB,";") S:PSEX="" PSEX="*NF*"
F X="PDOB","AD","TD" S @X=$E(@X,1,8)
;
NP ; last line and heading for next page
G:'BLF HEADER F Q1=$Y:1:(IOSL-4) W !
W !?5,OPN,?37,OSSN,?51,OWDN,?68,PSJORB Q:Q
;
I IOST["C-" K DIR S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S PSJDLW=1 Q
S PG=PG+1 W:$Y @IOF W !," AS OF: ",PSGPDT,?73-$L(PG),"Page: ",PG,!!!,?20,"THE FOLLOWING MEDICATIONS WILL EXPIRE",!?17,"FROM ",PSGEXPS," THROUGH ",PSGEXPF,!?10,"TO CONTINUE MEDICATIONS, PLEASE REORDER ON VA FORM 10-1158.",!!
S:$D(PSJSEL("TM")) TEAM=TM D ENTRY^PSJHEAD(PSGP,"",PG,"","")
;W !!?1,PPN,?36,"Ward: "_PWDN
;W !?7,"PID: "_PSSN,?30,"Weight(kg): "_WT,?61,"Admitted: ",AD
;W !?7,"DOB: "_PDOB_" ("_PAGE_")",?37,"Sex: "_PSEX W:TD ?53,"Last transferred: ",TD
;W !?8,"Dx: "_$S(DX]"":DX,1:"*NF*"),?$S($L(PRB)<9:61,1:69-$L(PRB)),"Room-Bed: ",PRB,!?1,"Reactions:" D ENRCT^PSGAPP
W !!?1,"Medication",?42,"ST",?45,"Start",?52,"Stop",?67,"Status/Info",!?3,"Dosage",?67,"Provider",!,LINE S BLF=1,OPN=PPN,PSJORB=PRB,OSSN=PSSN,OTM=PTM,OWDN=$E(PWDN,1,16) Q
;
WREC ; write Unit Dose record here
N X,PSG
D DRGDISP^PSJLMUT1(+PSGP,+PSJJORD_"U",39,39,.PSG,0)
S PSGOD=$$ENDTC^PSGMI($P(ND,"^",2)) W !!?1,PSG(1),?42,PST,?45,$E(PSGOD,1,5)_" "_PSD,?67,$P(ND,"^",4) I $P(ND,"^",8) W ?70,$E("HSM",$P(ND,"^",8),3)
;W !?1,PSG(2),?79-$L($P(ND,"^",5)),$P(ND,"^",5)
N MARX D TXT^PSGMUTL($P(ND,"^",5),24)
N DLINS,LN S DLINS=$O(PSG(""),-1)
F LN=2:1:$S(MARX-1>DLINS:MARX,1:DLINS+1) D
.W !,$G(PSG(LN)),?55,$G(MARX(LN-1))
;N X F X=2:0 S X=$O(PSG(X)) Q:'X W !?1,PSG(X)
;S WCNT=1,SI=$G(^PS(55,PSGP,5,PSJJORD,6)) I SI]"" W ! F S WRD=$P(SI," ",WCNT) Q:$L(WRD)=0 S WCNT=WCNT+1 W:$X+$L(WRD)>80 ! W " ",WRD
S SI=$P($G(^PS(55,PSGP,5,PSJJORD,6)),"^") I SI]"" W !?5,"Special Instructions: " F X=1:1:$L(SI," ") S Y=$P(SI," ",X) W:$X+$L(Y)>78 !?28 W Y," "
Q
WRECIV ; write IV record here
N DRG,P,ON55,PSG
S (FSTFLG,SNDFLG,LNCNT)=0
S PSGOD=$$ENDTC^PSGMI($P(ND,"^",2))
S DFN=PSGP,ON=+PSJJORD D GT55^PSIVORFB W !
N X F X=0:0 S X=$O(DRG("AD",X)) Q:'X D NAME^PSIVUTL(DRG("AD",X),39,.PSG,1) F JJ=0:0 S JJ=$O(PSG(JJ)) Q:'JJ W !?1,PSG(JJ) S LNCNT=LNCNT+1 D:LNCNT=1 FST D:LNCNT=2 SND
N X,PSG,JJ F X=0:0 S X=$O(DRG("SOL",X)) Q:'X D NAME^PSIVUTL(DRG("SOL",X),33,.PSG,0) F JJ=0:0 S JJ=$O(PSG(JJ)) Q:'JJ W ! W:JJ=1 ?3,"in" W ?6,PSG(JJ) S LNCNT=LNCNT+1 D:LNCNT=1 FST D:LNCNT=2 SND
W !?1,$P(P("MR"),U,2)_" "_P(9)_" "_P(8) D:'FSTFLG FST I FSTFLG&('SNDFLG) W ! D SND
S OPI=$P(P("OPI"),"^") I OPI]"" W !?5,"Other Print Info: " F X=1:1:$L(OPI," ") S Y=$P(OPI," ",X) W:$X+$L(Y)>78 !?28 W Y," "
Q
FST S FSTFLG=1 W ?42,PST,?45,$E(PSGOD,1,5)_" "_PSD,?67,P(17)
Q
SND S SNDFLG=1 W ?79-$L($P(P(6),U,2)),$P(P(6),U,2) Q
LIST ;**list IV orders, UD orders, or ALL
K DTOUT,DUOUT,DIR W ! S DIR(0)="SOAM^IV:IV;UD:Unit Dose;A:ALL",DIR("A")="List IV orders, Unit Dose orders, or All orders: ",DIR("B")="ALL",DIR("?")="Please enter a code."
S DIR("?",1)="Enter ""IV"" to see only IV orders, ""UD"" to see only Unit",DIR("?",2)="Dose orders, or ""A"" to see both IV and Unit Dose orders." D ^DIR K DIR S:$D(DTOUT)!($D(DUOUT)) OUT=1 S CHOICE=Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJEXP0 4931 printed Apr 09, 2024@21:09:22 Page 2
PSJEXP0 ;BIR/CML3,KKA - PRINTS MEDICATION EXPIRATION NOTICES ;13 FEB 96 / 10:04 AM
+1 ;;5.0;INPATIENT MEDICATIONS ;**50,58,328**;16 DEC 97;Build 6
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA# 2191.
+4 ;
+5 DO NOW^%DTC
SET PSGDT=%
SET PSGOD=$$ENDTC^PSGMI(PSGDT)
USE IO
+6 IF '$DATA(^TMP("PSG",$JOB))
Begin DoDot:1
+7 if IO'=(IO(0)!(IOST'["C-"))&($Y)
WRITE @IOF
WRITE !!," AS OF ",PSGOD,!,"NO EXPIRED ORDERS FROM ",PSGEXPS," THROUGH ",PSGEXPF,!,"FOR ",$SELECT(PSGSS="P":"PATIENT",PSGSS="W":"WARD",PSGSS="C":"CLINIC",PSGSS="L":"CLINIC GROUP",1:"WARD GROUP"),": ",PSJMSG,"."
End DoDot:1
GOTO DONE
+8 SET PSGPDT=PSGOD
SET (BLF,LINE,PSSN,Q,TM,WDN,RB,PN)=""
SET PG=0
SET $PIECE(LINE,"-",81)=""
KILL PSJDLW
+9 FOR
SET TM=$ORDER(^TMP("PSG",$JOB,TM))
if TM=""!$GET(PSJDLW)
QUIT
FOR
SET WDN=$ORDER(^TMP("PSG",$JOB,TM,WDN))
if WDN=""!$GET(PSJDLW)
QUIT
FOR
SET RB=$ORDER(^TMP("PSG",$JOB,TM,WDN,RB))
if RB=""!$GET(PSJDLW)
QUIT
DO STRT1
+10 SET Q=1
if '$GET(PSJDLW)
DO NP
+11 ;
DONE ;
+1 if (IO'=IO(0)!(IOST'["C-"))&($Y)
WRITE @IOF
KILL AD,BLF,DX,LINE,OPN,PSJORB,OSSN,OTM,OWDN,PAGE,PDOB,PG,PN,PRB,PSD,PSGPDT,PSSN,PST,PTM,PWDN,RCT,Q1,RB,TD,WDRG
+2 QUIT
+3 ;
STRT1 ;
+1 FOR
SET PN=$ORDER(^TMP("PSG",$JOB,TM,WDN,RB,PN))
if PN=""!$GET(PSJDLW)
QUIT
SET ND=^(PN)
DO INFO
FOR SD=0:0
SET SD=$ORDER(^TMP("PSG",$JOB,TM,WDN,RB,PN,SD))
if 'SD!$GET(PSJDLW)
QUIT
DO PRT
+2 QUIT
+3 ;
PRT ;
+1 SET PSD=$$ENDTC^PSGMI(SD)
+2 FOR PST="C","O","OC","P","R"
SET DRG=""
FOR
SET DRG=$ORDER(^TMP("PSG",$JOB,TM,WDN,RB,PN,SD,PST,DRG))
if DRG=""!$GET(PSJDLW)
QUIT
SET ND=^(DRG)
SET PSJJORD=$PIECE(DRG,"^",2)
if $Y+6>IOSL
DO NP
IF '$GET(PSJDLW)
if PSJJORD'["V"
DO WREC
IF PSJJORD["V"
SET PSJJORD=$PIECE(PSJJORD,"V")
DO WRECIV
+3 QUIT
+4 ;
INFO ;
+1 SET PSGP=$PIECE(PN,"^",2)
SET PTM=$PIECE(ND,"^")
SET PWDN=$PIECE(ND,"^",2)
SET PRB=$PIECE(ND,"^",3)
SET PPN=$PIECE(ND,"^",4)
if PPN=PSGP
SET PPN=PPN_";DPT("
FOR X="PTM","PWDN","PRB"
IF @X="zz"
SET @X="*NF*"
+2 SET PSEX=$PIECE(ND,"^",5)
SET PDOB=$PIECE(ND,"^",6)
SET PSSN=$PIECE(ND,"^",7)
SET DX=$PIECE(ND,"^",8)
SET WT=$PIECE(ND,"^",9)
SET AD=$PIECE(ND,"^",10)
SET TD=$PIECE(ND,"^",11)
SET PAGE=$SELECT($PIECE(PDOB,";",2):$PIECE(PDOB,";",2),1:"?")
SET PDOB=$PIECE(PDOB,";")
if PSEX=""
SET PSEX="*NF*"
+3 FOR X="PDOB","AD","TD"
SET @X=$EXTRACT(@X,1,8)
+4 ;
NP ; last line and heading for next page
+1 if 'BLF
GOTO HEADER
FOR Q1=$Y:1:(IOSL-4)
WRITE !
+2 WRITE !?5,OPN,?37,OSSN,?51,OWDN,?68,PSJORB
if Q
QUIT
+3 ;
+1 IF IOST["C-"
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET PSJDLW=1
QUIT
+2 SET PG=PG+1
if $Y
WRITE @IOF
WRITE !," AS OF: ",PSGPDT,?73-$LENGTH(PG),"Page: ",PG,!!!,?20,"THE FOLLOWING MEDICATIONS WILL EXPIRE",!?17,"FROM ",PSGEXPS," THROUGH ",PSGEXPF,!?10,"TO CONTINUE MEDICATIONS, PLEASE REORDER ON VA FORM 10-1158.",!!
+3 if $DATA(PSJSEL("TM"))
SET TEAM=TM
DO ENTRY^PSJHEAD(PSGP,"",PG,"","")
+4 ;W !!?1,PPN,?36,"Ward: "_PWDN
+5 ;W !?7,"PID: "_PSSN,?30,"Weight(kg): "_WT,?61,"Admitted: ",AD
+6 ;W !?7,"DOB: "_PDOB_" ("_PAGE_")",?37,"Sex: "_PSEX W:TD ?53,"Last transferred: ",TD
+7 ;W !?8,"Dx: "_$S(DX]"":DX,1:"*NF*"),?$S($L(PRB)<9:61,1:69-$L(PRB)),"Room-Bed: ",PRB,!?1,"Reactions:" D ENRCT^PSGAPP
+8 WRITE !!?1,"Medication",?42,"ST",?45,"Start",?52,"Stop",?67,"Status/Info",!?3,"Dosage",?67,"Provider",!,LINE
SET BLF=1
SET OPN=PPN
SET PSJORB=PRB
SET OSSN=PSSN
SET OTM=PTM
SET OWDN=$EXTRACT(PWDN,1,16)
QUIT
+9 ;
WREC ; write Unit Dose record here
+1 NEW X,PSG
+2 DO DRGDISP^PSJLMUT1(+PSGP,+PSJJORD_"U",39,39,.PSG,0)
+3 SET PSGOD=$$ENDTC^PSGMI($PIECE(ND,"^",2))
WRITE !!?1,PSG(1),?42,PST,?45,$EXTRACT(PSGOD,1,5)_" "_PSD,?67,$PIECE(ND,"^",4)
IF $PIECE(ND,"^",8)
WRITE ?70,$EXTRACT("HSM",$PIECE(ND,"^",8),3)
+4 ;W !?1,PSG(2),?79-$L($P(ND,"^",5)),$P(ND,"^",5)
+5 NEW MARX
DO TXT^PSGMUTL($PIECE(ND,"^",5),24)
+6 NEW DLINS,LN
SET DLINS=$ORDER(PSG(""),-1)
+7 FOR LN=2:1:$SELECT(MARX-1>DLINS:MARX,1:DLINS+1)
Begin DoDot:1
+8 WRITE !,$GET(PSG(LN)),?55,$GET(MARX(LN-1))
End DoDot:1
+9 ;N X F X=2:0 S X=$O(PSG(X)) Q:'X W !?1,PSG(X)
+10 ;S WCNT=1,SI=$G(^PS(55,PSGP,5,PSJJORD,6)) I SI]"" W ! F S WRD=$P(SI," ",WCNT) Q:$L(WRD)=0 S WCNT=WCNT+1 W:$X+$L(WRD)>80 ! W " ",WRD
+11 SET SI=$PIECE($GET(^PS(55,PSGP,5,PSJJORD,6)),"^")
IF SI]""
WRITE !?5,"Special Instructions: "
FOR X=1:1:$LENGTH(SI," ")
SET Y=$PIECE(SI," ",X)
if $X+$LENGTH(Y)>78
WRITE !?28
WRITE Y," "
+12 QUIT
WRECIV ; write IV record here
+1 NEW DRG,P,ON55,PSG
+2 SET (FSTFLG,SNDFLG,LNCNT)=0
+3 SET PSGOD=$$ENDTC^PSGMI($PIECE(ND,"^",2))
+4 SET DFN=PSGP
SET ON=+PSJJORD
DO GT55^PSIVORFB
WRITE !
+5 NEW X
FOR X=0:0
SET X=$ORDER(DRG("AD",X))
if 'X
QUIT
DO NAME^PSIVUTL(DRG("AD",X),39,.PSG,1)
FOR JJ=0:0
SET JJ=$ORDER(PSG(JJ))
if 'JJ
QUIT
WRITE !?1,PSG(JJ)
SET LNCNT=LNCNT+1
if LNCNT=1
DO FST
if LNCNT=2
DO SND
+6 NEW X,PSG,JJ
FOR X=0:0
SET X=$ORDER(DRG("SOL",X))
if 'X
QUIT
DO NAME^PSIVUTL(DRG("SOL",X),33,.PSG,0)
FOR JJ=0:0
SET JJ=$ORDER(PSG(JJ))
if 'JJ
QUIT
WRITE !
if JJ=1
WRITE ?3,"in"
WRITE ?6,PSG(JJ)
SET LNCNT=LNCNT+1
if LNCNT=1
DO FST
if LNCNT=2
DO SND
+7 WRITE !?1,$PIECE(P("MR"),U,2)_" "_P(9)_" "_P(8)
if 'FSTFLG
DO FST
IF FSTFLG&('SNDFLG)
WRITE !
DO SND
+8 SET OPI=$PIECE(P("OPI"),"^")
IF OPI]""
WRITE !?5,"Other Print Info: "
FOR X=1:1:$LENGTH(OPI," ")
SET Y=$PIECE(OPI," ",X)
if $X+$LENGTH(Y)>78
WRITE !?28
WRITE Y," "
+9 QUIT
FST SET FSTFLG=1
WRITE ?42,PST,?45,$EXTRACT(PSGOD,1,5)_" "_PSD,?67,P(17)
+1 QUIT
SND SET SNDFLG=1
WRITE ?79-$LENGTH($PIECE(P(6),U,2)),$PIECE(P(6),U,2)
QUIT
LIST ;**list IV orders, UD orders, or ALL
+1 KILL DTOUT,DUOUT,DIR
WRITE !
SET DIR(0)="SOAM^IV:IV;UD:Unit Dose;A:ALL"
SET DIR("A")="List IV orders, Unit Dose orders, or All orders: "
SET DIR("B")="ALL"
SET DIR("?")="Please enter a code."
+2 SET DIR("?",1)="Enter ""IV"" to see only IV orders, ""UD"" to see only Unit"
SET DIR("?",2)="Dose orders, or ""A"" to see both IV and Unit Dose orders."
DO ^DIR
KILL DIR
if $DATA(DTOUT)!($DATA(DUOUT))
SET OUT=1
SET CHOICE=Y
+3 QUIT
