source: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJEXP0.m@ 623

Last change on this file since 623 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.7 KB
Line 
1PSJEXP0 ;BIR/CML3,KKA-PRINTS MEDICATION EXPIRATION NOTICES ;13 FEB 96 / 10:04 AM
2 ;;5.0; INPATIENT MEDICATIONS ;**50,58**;16 DEC 97
3 ;
4 ; Reference to ^PS(55 is supported by DBIA# 2191.
5 ;
6 D NOW^%DTC S PSGDT=%,PSGOD=$$ENDTC^PSGMI(PSGDT) U IO
7 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
8 S PSGPDT=PSGOD,(BLF,LINE,PSSN,Q,TM,WDN,RB,PN)="",PG=0,$P(LINE,"-",81)="" K PSJDLW
9 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
10 S Q=1 D:'$G(PSJDLW) NP
11 ;
12DONE ;
13 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
14 Q
15 ;
16STRT1 ;
17 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
18 Q
19 ;
20PRT ;
21 S PSD=$$ENDTC^PSGMI(SD)
22 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
23 Q
24 ;
25INFO ;
26 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*"
27 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*"
28 F X="PDOB","AD","TD" S @X=$E(@X,1,8)
29 ;
30NP ; last line and heading for next page
31 G:'BLF HEADER F Q1=$Y:1:(IOSL-4) W !
32 W !?5,OPN,?37,OSSN,?51,OWDN,?68,PSJORB Q:Q
33 ;
34HEADER ;
35 I IOST["C-" K DIR S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S PSJDLW=1 Q
36 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.",!!
37 S:$D(PSJSEL("TM")) TEAM=TM D ENTRY^PSJHEAD(PSGP,"",PG,"","")
38 ;W !!?1,PPN,?36,"Ward: "_PWDN
39 ;W !?7,"PID: "_PSSN,?30,"Weight(kg): "_WT,?61,"Admitted: ",AD
40 ;W !?7,"DOB: "_PDOB_" ("_PAGE_")",?37,"Sex: "_PSEX W:TD ?53,"Last transferred: ",TD
41 ;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
42 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
43 ;
44WREC ; write Unit Dose record here
45 N X,PSG
46 D DRGDISP^PSJLMUT1(+PSGP,+PSJJORD_"U",39,39,.PSG,0)
47 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)
48 ;W !?1,PSG(2),?79-$L($P(ND,"^",5)),$P(ND,"^",5)
49 N MARX D TXT^PSGMUTL($P(ND,"^",5),24)
50 N DLINS,LN S DLINS=$O(PSG(""),-1)
51 F LN=2:1:$S(MARX-1>DLINS:MARX,1:DLINS+1) D
52 .W !,$G(PSG(LN)),?55,$G(MARX(LN-1))
53 ;N X F X=2:0 S X=$O(PSG(X)) Q:'X W !?1,PSG(X)
54 ;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
55 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," "
56 Q
57WRECIV ; write IV record here
58 N DRG,P,ON55,PSG
59 S (FSTFLG,SNDFLG,LNCNT)=0
60 S PSGOD=$$ENDTC^PSGMI($P(ND,"^",2))
61 S DFN=PSGP,ON=+PSJJORD D GT55^PSIVORFB W !
62 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
63 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
64 W !?1,$P(P("MR"),U,2)_" "_P(9)_" "_P(8) D:'FSTFLG FST I FSTFLG&('SNDFLG) W ! D SND
65 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," "
66 Q
67FST S FSTFLG=1 W ?42,PST,?45,$E(PSGOD,1,5)_" "_PSD,?67,P(17)
68 Q
69SND S SNDFLG=1 W ?79-$L($P(P(6),U,2)),$P(P(6),U,2) Q
70LIST ;**list IV orders, UD orders, or ALL
71 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."
72 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
73 Q
Note: See TracBrowser for help on using the repository browser.