- PSJEXP0 ;BIR/CML3,KKA-PRINTS MEDICATION EXPIRATION NOTICES ;27-Aug-2004 09:14;PLS
- ;;5.0; INPATIENT MEDICATIONS ;**50,58**;16 DEC 97
- ;
- ; Reference to ^PS(55 is supported by DBIA# 2191.
- ;
- ; Modified - IHS/CIA/PLS - 08/27/04 - HEADER+2
- D NOW^%DTC S PSGDT=%,PSGOD=$$ENDTC^PSGMI(PSGDT) U IO
- I '$D(^TMP("PSG",$J)) 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",1:"WARD GROUP"),": ",PSJMSG,"." G DONE
- 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
- ; IHS/CIA/PLS - 08/27/04 - Removed reference to VA FORM
- ;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 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,!?18,"TO CONTINUE MEDICATIONS, PLEASE REORDER.",!!
- 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
- PSJEXP0 ;BIR/CML3,KKA-PRINTS MEDICATION EXPIRATION NOTICES ;27-Aug-2004 09:14;PLS
- +1 ;;5.0; INPATIENT MEDICATIONS ;**50,58**;16 DEC 97
- +2 ;
- +3 ; Reference to ^PS(55 is supported by DBIA# 2191.
- +4 ;
- +5 ; Modified - IHS/CIA/PLS - 08/27/04 - HEADER+2
- +6 DO NOW^%DTC
- SET PSGDT=%
- SET PSGOD=$$ENDTC^PSGMI(PSGDT)
- USE IO
- +7 IF '$DATA(^TMP("PSG",$JOB))
- 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",1:"WARD GROUP"),": ",PSJMSG,"."
- 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 ; IHS/CIA/PLS - 08/27/04 - Removed reference to VA FORM
- +3 ;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.",!!
- +4 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,!?18,"TO CONTINUE MEDICATIONS, PLEASE REORDER.",!!
- +5 IF $DATA(PSJSEL("TM"))
- SET TEAM=TM
- DO ENTRY^PSJHEAD(PSGP,"",PG,"","")
- +6 ;W !!?1,PPN,?36,"Ward: "_PWDN
- +7 ;W !?7,"PID: "_PSSN,?30,"Weight(kg): "_WT,?61,"Admitted: ",AD
- +8 ;W !?7,"DOB: "_PDOB_" ("_PAGE_")",?37,"Sex: "_PSEX W:TD ?53,"Last transferred: ",TD
- +9 ;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
- +10 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
- +11 ;
- 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
