source: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVLBL1.m@ 636

Last change on this file since 636 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 6.5 KB
Line 
1PSIVLBL1 ;BIR/RGY-PRINT LABEL FROM WARD LIST ;24 Aug 2001 3:59 PM
2 ;;5.0; INPATIENT MEDICATIONS ;**69,58,81,97,104**;16 DEC 97
3 ;
4 ; Reference to ^PS(55 is supported by DBIA 2191.
5 ; Reference to ^%DT is supported by DBIA 10003.
6 ; Reference to ^%ZIS is supported by DBIA 10086.
7 ; Reference to ^%ZTLOAD is supported by DBIA 10063.
8 ; Reference to ^DICN is supported by DBIA 10009.
9 ; Reference to ^DIR is supported by DBIA 10026.
10 ; Reference to ^VALM1 is supported by DBIA 10116.
11 ;
12START S Y=1 W !!,"Schedule labels for DATE: TODAY//" R X:DTIME S:'$T X="^" S:X="" X="T" Q:X["^" I X'["?" S %DT="EX" D ^%DT
13 G:Y<1 START
14 I X["?" S HELP="LBL1" D ^PSIVHLP S X="?" D ^%DT G START
15ASK S PSIVDT=Y\1 D ^PSIVWL1 G QUIT:'$D(PSIVOD)!('$D(PSIVCD))
16 I PSIVPL'=ION D QUE G QUIT
17DEQ ;
18 L +^PS(55,"PSIVWL",PSIVSN):1 E W:$Y @IOF W !!,"**** WARNING --- LABELS NOT",!," RUN, WARD LIST IN PROGRESS" G QUIT
19 S PSIVT="" F PSIVLBL1=0:0 S PSIVT=$O(PSIVOD(PSIVT)) Q:PSIVT="" S WRD="" D @("LBL"_$S($D(^PS(55,"PSIVWLM",PSIVSN,PSIVT_PSIVOD(PSIVT))):"M",1:"W"))
20 I $G(PSJRPFLG) D
21 . W !!,"*** NOTE ***"
22 . W !!,"Schedule labels had already printed for the selected manufacturing time."
23 . W !,"Please use the Reprint Scheduled Labels option instead.",!
24 . K PSJRPFLG
25QUIT L -^PS(55,"PSIVWL",PSIVSN) S:$D(ZTQUEUED) ZTREQ="@" K %,%DT,%T,D,DFN,I,JJ,NOFLG,ON,P,PSCT,PSIV,PSIVCD,PSIVDT,PSIVDOSE,PSIVMT,PSIVOD,PSIVNOL,PSIVT,VAERR,WRD,X,X1,X2,Y,Z,ZTSK,OIX1,OIX2
26 Q
27LBLM ;
28 N OIX1,OIX2 I '$D(^PS(55,"PSIVWLM",PSIVSN,PSIVT_PSIVOD(PSIVT),PSIVT)) D DESC(PSIVT) Q
29 S OIX1=0 F S OIX1=$O(^PS(55,"PSIVWLM",PSIVSN,PSIVT_PSIVOD(PSIVT),PSIVT,OIX1)) Q:OIX1="" S OIX2=0 F S OIX2=$O(^PS(55,"PSIVWLM",PSIVSN,PSIVT_PSIVOD(PSIVT),PSIVT,OIX1,OIX2)) Q:OIX2="" D LBLM1
30 K JX Q
31LBLM1 ;
32 S NOFLG=1 N DFNX,ONX
33 S DFNX=0 F S DFNX=$O(^PS(55,"PSIVWLM",PSIVSN,PSIVT_PSIVOD(PSIVT),PSIVT,OIX1,OIX2,DFNX)) Q:'DFNX D
34 . S DFN=+DFNX D ENIV^PSJAC S DFN=DFNX,ONX=0 F S ONX=$O(^PS(55,"PSIVWLM",PSIVSN,PSIVT_PSIVOD(PSIVT),PSIVT,OIX1,OIX2,DFN,ONX)) Q:'ONX D
35 .. S ON=+ONX,WRD=$P(^(+ON),"^",2),X1=OIX1,X2=OIX2 D MEOW
36 ; naked reference on line above refers to the ^PS(55,"PSIVWLM" reference on the line preceding the naked reference
37 D:NOFLG DESC(PSIVT)
38 Q
39LBLW ; loop through ward lists
40 N DFNX,ONX,WRDX
41 S NOFLG=1 S WRDX=0 F S WRDX=$O(^PS(55,"PSIVWL",PSIVSN,WRDX)) Q:WRDX="" D
42 . S WRD=WRDX S DFNX=0 F S DFNX=$O(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_PSIVOD(PSIVT),DFNX)) Q:'DFNX D
43 .. S DFN=+DFNX D ENIV^PSJAC S DFN=DFNX S ONX=0 F S ONX=$O(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_PSIVOD(PSIVT),DFN,ONX)) Q:'ONX S ON=+ONX D MEOW
44 D:NOFLG DESC(PSIVT)
45 Q
46MEOWRPT ;Reprint from man/ward list
47 I '$O(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_PSIVOD(PSIVT),DFN,+ON,0)) D MEOW Q
48 S PSIVWMFL=1 ;this flag indicate prt/reprt from war/man list
49 NEW PSJID,PSIVOID,PSIVID,X,XX
50 F PSJID=0:0 S PSJID=$O(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_PSIVOD(PSIVT),DFN,+ON,PSJID)) Q:'PSJID D REPRT
51 ;
52 ; Kill old ID and set newly reprinted ID.
53 ;
54 F X=0:0 S X=$O(PSIVOID(X)) Q:'X D
55 . K ^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_PSIVOD(PSIVT),DFN,+ON,X)
56 F X=0:0 S X=$O(PSIVID(X)) Q:'X D
57 . S ^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_PSIVOD(PSIVT),DFN,+ON,X)=""
58 K PSIVWMFL,PSIVOID,PSIVID
59 Q
60REPRT ; Reprint labels using existing bcma ID
61 S PSIVOID(PSJID)=""
62 NEW PSJLB S XX=$G(^PS(55,DFN,"IVBCMA",PSJID,0)) Q:XX=""
63 F X=1:1:8 S PSJLB(X)=$P(XX,U,X)
64 I $S(PSJLB(4)="C":1,PSJLB(4)="G":1,PSJLB(4)="I":1,PSJLB(7)'="":1,1:0) Q
65 S PSIVCTD=0,PSIVCT=1,PSIVNOL=1,P(4)=$P(^PS(55,DFN,"IV",+ON,0),"^",4)
66 D REPRT^PSIVLBRP(DFN_"V"_PSJID)
67 Q
68MEOW ; Print labels
69 S PSIVCT=1,PSIVNOL=+^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_PSIVOD(PSIVT),DFN,+ON),P16=$P(^(+ON),"^",3),PSIVDOSE=$P(^(+ON),"^",2) I '$P(^(+ON),"^",4) S $P(^(+ON),"^",4)=1 K PSIVCT
70 I PSIVNOL=0 K PSIVDOSE,PSIVCT,PSIVWMFL,PSIVID Q
71 N PSJSCH,PSJST,A,PSJOK
72 S PSJSCH=$P(^PS(55,DFN,"IV",+ON,0),"^",9),PSJST=$$ONE^PSJBCMA(DFN,ON,PSJSCH)
73 S PSJOK=1 I PSJST="O" S A=0 F S A=$O(^PS(55,DFN,"IV",+ON,"LAB",A)) Q:A="" I $P($G(^(A,0)),"^",3)=1 S PSJOK=0 Q
74 Q:'PSJOK
75 Q:"HOD"[$P(^PS(55,DFN,"IV",+ON,0),"^",17)
76 I $O(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_PSIVOD(PSIVT),DFN,ON,0)) D Q
77 . S NOFLG=0,PSJRPFLG=1
78 S PSIVWMFL=1
79 S IONOFF="",P(4)=$P(^PS(55,DFN,"IV",+ON,0),"^",4),ACTION=1,TRACK=2 D ^PSIVLTR D ^PSIVHYPL:P(4)="H",^PSIVLABL:"APSC"[P(4)
80 I $D(PSIVID) S X=0 F S X=$O(PSIVID(X)) Q:'X D
81 . S ^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_PSIVOD(PSIVT),DFN,ON,X)=""
82 S NOFLG=0
83 K PSIVDOSE,PSIVCT,PSIVWMFL,PSIVID Q
84 ;
85QUE S ZTIO=PSIVPL,ZTDESC="PRINT SCHEDULED IV LABELS",ZTRTN="DEQ^PSIVLBL1",PSIVT="",ZTSAVE("PSJSYSP0")=""
86 F I=0:0 S PSIVT=$O(PSIVMT(PSIVT)) Q:PSIVT="" S (ZTSAVE("PSIVCD("""_PSIVT_""")"),ZTSAVE("PSIVMT("""_PSIVT_""")"),ZTSAVE("PSIVOD("""_PSIVT_""")"))=""
87 F X="PSIVSN","PSIVSITE","PSJSYSW0","PSJSYSU","IONOFF" S ZTSAVE(X)=""
88 D ^%ZTLOAD W:$D(ZTSK) !,"Queued." Q
89 ;
90ENLBLI ;Print individual labels.
91 D FULL^VALM1
92 S PSJORD=ON D ENNH^PSIVORV2(ON)
93 I ON'["V" W !!,$C(7),$C(7),"You may not print labels for a pending order." W ! K DIR S DIR(0)="E" D ^DIR K DIR G Q
94A1 ;
95 I "EDP"[$P(^PS(55,DFN,"IV",+ON,0),U,17) W !,$C(7),$C(7),"WARNING, this order is not active.",!,"Continue" S %=2 D YN^DICN G:%=2!(%=-1) Q G:%=0 A1
96 D PAUSE^VALM1
97 S PSIVLBTP=1,PSJMORE=0 D EN^VALM("PSJ LM IV LABELS") G Q
98LBLBEG R !!,"Number of labels to print: ",X:DTIME Q:'$T!("^"[X) S:X["?" HELP="NOL" D:X["?" ^PSIVHLP1 G:X["?" LBLBEG K:X'=+X!(X>10)!(X<1)!(X?.E1"."1N.N) X W:'$D(X) $C(7),$C(7),"??" G:'$D(X) LBLBEG S PSIVNOL=+X,PSIVCT=1
99 ;
100USAGE ;
101 W !,"Count as daily usage" S %=1 D YN^DICN G:%=-1 Q K:%=1 PSIVCT I %=0 S HELP="NCILBL" D ^PSIVHLP1 G USAGE
102 S P16=$S('$D(PSIVCT):$P(^PS(55,DFN,"IV",+ON,0),"^",16),1:0) S:'$D(PSIVCT) $P(^(0),"^",16)=P16+X
103 S IONOFF="",IOP=PSIVPL,%ZIS="NQ" D ^%ZIS G:POP Q I IO=IO(0),($E(IOST)="C") W !!! D DEQIA,Q D HOME^%ZIS Q
104 D HOME^%ZIS
105 W ! S ZTDTH=$H,ZTIO=PSIVPL,ZTDESC="PRINT INDIVIDUAL IV LABELS",ZTRTN="DEQIA^PSIVLBL1" F X="IONOFF","P16","PSIVAC","PSIVNOL","PSIVSN","PSIVSITE","DFN","ON","PSJSYSW0","PSJSYSU","PSJSYSP0" S ZTSAVE(X)=""
106 S:$D(PSIVCT) ZTSAVE("PSIVCT")="" D ^%ZTLOAD W:$D(ZTSK) !,"Queued."
107Q ;K %,IONOFF,ON,ORNS,ORPV,ORSTOP,ORSTRT,ORSTS,ORVP,P,PSIVC,PSIVREA,J,N,N2,ORIFN,P17,SCHED,PSIVDOSE,PSIVNOL,PSIVNOW,VAERR
108 K %,IONOFF,ORNS,ORPV,ORSTOP,ORSTRT,ORSTS,ORVP,PSIVC,PSIVREA,J,N,N2,ORIFN,P17,SCHED,PSIVDOSE,PSIVNOL,PSIVNOW,VAERR
109 Q
110DEQIA ;
111 K PSIVDOSE S P(4)=$P(^PS(55,DFN,"IV",+ON,0),"^",4)
112 S ACTION=1,TRACK=1 D ^PSIVLTR
113 ;
114 D ^PSIVHYPL:P(4)="H",^PSIVLABL:"APSC"[P(4) S:$D(ZTQUEUED) ZTREQ="@"
115 Q
116DESC(X) ;Expand the IV type.
117 NEW XX,Y,DESC,X1,X2 S Y=$$CODES^PSIVUTL(X,55.01,.04)
118 S XX="***NO "_Y_" DATA***"
119 NEW MARX D TXT^PSGMUTL(XX,$P(PSIVSITE,U,13))
120 F XX=1:1:(+PSIVSITE+$P(PSIVSITE,U,16)) W:XX>2 $G(MARX(XX-2)) W !
121 Q
Note: See TracBrowser for help on using the repository browser.