source: FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOER.m@ 1008

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

initial load of FOIAVistA 6/30/08 version

File size: 9.5 KB
Line 
1PSGOER ;BIR/CML3-RENEW A SINGLE ORDER ;07 MAR 96 / 1:23 PM
2 ;;5.0; INPATIENT MEDICATIONS ;**11,30,29,35,70,58,95,110,111,133,141**;16 DEC 97
3 ;
4 ; Reference to ^PS(51.1 supported by DBIA 2177.
5 ; Reference to ^PS(55 supported by DBIA 2191.
6 ; Reference to ^PSSLOCK is supported by DBIA 2789.
7 ; Reference to ^PSBAPIPM is supported by DBIA 3564.
8 ; Reference to ^PS(59.7 is supported by DBIA 2181.
9 ;
10 ; renew a single order
11 I $G(PSJCOM) D ^PSJCOMR Q
12 N PSJEXPIR S PSJEXPIR=$$EXPIRED(PSGP,PSGORD) I PSJEXPIR D Q
13 .W !!?3," THIS ORDER" W:PSJEXPIR'=2 " HAS BEEN INACTIVE FOR ONE OR MORE SCHEDULED",!?8," ADMINISTRATIONS AND"
14 .W " CANNOT BE RENEWED!" D PAUSE^VALM1
15 I $G(PSGSCH)]"",($G(PSGS0XT)="D"),($G(PSGAT)="") D Q
16 .N SWD,SDW,XABB,X,QX S X=$G(PSGSCH) D DW^PSGS0 Q:($G(X)="") I $G(PSGS0XT)="" S PSGS0XT="D"
17 .Q:((",P,R,")[(","_$G(PSGST)_","))
18 .I $G(PSGS0XT)="D",$G(PSGAT)="" S CHK=1 W !!?3,"This order contains a 'DAY OF THE WEEK' schedule without admin times"
19 .W !?11," and CANNOT be renewed!" D PAUSE^VALM1
20 I $G(PSGSCH)]"",'$$DOW^PSIVUTL(PSGSCH),'$$PRNOK^PSGS0(PSGSCH) I '$D(^PS(51.1,"AC","PSJ",PSGSCH)) D Q
21 .W !!?3,"This order contains an invalid schedule and CANNOT be renewed!" D PAUSE^VALM1
22 W !! K DIR S DIR(0)="Y",DIR("A")=$S($P(PSJSYSP0,"^",3):"RENEW THIS ORDER",1:"MARK THIS ORDER FOR RENEWAL"),DIR("B")="YES"
23 S DIR("?")="Answer 'YES' to "_$S($P(PSJSYSP0,"^",3):"renew this order",1:"mark this order for renewal")_". Answer 'NO' (or '^') to stop now." D ^DIR
24 I '$D(DIRUT),Y D NEW S PSGCANFL=1 D DONE Q
25 I '$D(DIRUT),PSJSYSU S PSGND4=$G(^PS(55,PSGP,5,+PSGORD,4)) I $P(PSGND4,"^",15),$P(PSGND4,"^",16) D UNMARK,DONE Q
26 D DONE,ABORT^PSGOEE
27 Q
28 ;
29UNMARK ;
30 W !!,"THIS ORDER HAS BEEN 'MARKED FOR RENEWAL'.",! K DIR S DIR(0)="Y",DIR("A")="DO YOU WANT TO 'UNMARK IT'",DIR("B")="NO"
31 S DIR("?",1)=" Answer 'YES' to unmark this order. Answer 'NO' (or '^') to leave the order",DIR("?")="marked. (An answer is required.)" D ^DIR
32 I 'Y D ABORT^PSGOEE G DONE
33 S DA(1)=PSGP,DA=+PSGORD,PSGAL("C")=21180+PSJSYSU D ^PSGAL5 S $P(PSGND4,"^",15,17)="^^",^PS(55,PSGP,5,DA,4)=PSGND4 W "...DONE!"
34 ;
35DONE ;
36 K %DT,DA,DIE,DIR,DR,FDSD,PSGAL,PSGALR,PSGDL,PSGDLS,PSGFD,PSGFOK,PSGND4,PSGOEE,PSGOER0,PSGOER1,PSGOER2,PSGOERDP,PSGOPR,PSGOSD,PSGPOSA,PSGPOSD,PSGPR,PSGPX,PSGRD,PSGSD,PSGTOL,PSGTOO,PSGUOW,PSGWLL,RF Q
37 ;
38NEW ; get info, write record
39EXTEND ; extend stop date on renewal order
40 N DUOUT,PSJABT,PSGDRG,PSJREN,PSGOREAS S PSGDRG=$P($G(^PS(55,PSGP,5,+PSGORD,1,1,0)),"^"),PSJREN=1
41 I $G(PSGST)="O" N ACT S ACT=$$EN^PSBAPIPM(PSGP,PSGORD) I $P(ACT,"^",2),($P(ACT,"^",3)="G") I $P(ACT,"^",2)>$P($G(^PS(55,PSGP,5,+PSGORD,2)),"^",2) D Q
42 . W !!?5,"THIS ONE-TIME ORDER HAS ALREADY BEEN GIVEN AND CANNOT BE RENEWED",! S (DIRUT,PSGORQF)=1 D READ
43 D OC55
44 Q:$D(PSGORQF) ; quit if not to continue
45 D NOW^%DTC S PSGDT=%,PSGND4=$G(^PS(55,PSGP,5,+PSGORD,4)) I '$P(PSJSYSP0,"^",3) D MARK Q
46 S PSGWLL=$S('$P(PSJSYSW0,"^",4):0,1:+$G(^PS(55,PSGP,5.1))),PSGOEE="R" K PSGOEOS
47 K ^PS(53.45,PSJSYSP,1),^(2) D MOVE(3,1),MOVE(1,2)
48 D DATE^PSGOER0(PSGP,PSGORD,PSGDT) I ($G(X)="^")!'$D(PSGFOK(106))!$G(DUOUT) D DONE,ABORT^PSGOEE S VALMBCK="R",COMQUIT=1 Q
49SPEED ;
50 I +$G(PSJSYSU)=3 D EN^PSGPEN(PSGORD)
51 Q:$G(DUOUT)
52 N PSGOEAV S PSGOEAV=+PSJSYSU
53 W !!,"...updating order..." K DA S DA(1)=PSGP,DA=+PSGORD,PSGAL("C")=PSJSYSU*10+18000 D ^PSGAL5 W "."
54 I $$LS^PSSLOCK(PSGP,PSGORD) D UPDREN(PSGORD,PSGDT,PSGOEPR,PSGOFD,PSJNOO),UPDRENOE(PSGP,PSGORD,PSGDT) D UNL^PSSLOCK(PSGP,PSGORD)
55 ;
56 I 'PSGOERDP,$P(PSJSYSW0,"^",4),PSGFD'<PSGWLL S $P(^PS(55,PSGP,5.1),"^")=+PSGFD
57 W ".DONE!" S VALMBCK="Q" Q
58 ;
59MARK ;
60 I $P(PSGND4,"^",15),$P(PSGND4,"^",16) W $C(7),!!?3,"...THIS ORDER IS ALREADY MARKED FOR RENEWAL!..." Q
61 K DA S $P(PSGND4,"^",15,17)="1^"_DUZ_"^"_PSGDT,^PS(55,PSGP,5,+PSGORD,4)=PSGND4,PSGAL("C")=13180,DA(1)=PSGP,DA=+PSGORD W "." D ^PSGAL5
62 I $D(PSJSYSO) S PSGORD=+PSGORD_"A",PSGPOSA="R",PSGPOSD=PSGDT D ENPOS^PSGVDS
63 Q
64MOVE(X,Y) ; Move comments/dispense drugs from 55 to 53.45.
65 S Q=0 F S Q=$O(^PS(55,PSGP,5,+PSGORD,X,Q)) Q:'Q S ^PS(53.45,PSJSYSP,Y,Q,0)=$G(^(Q,0))
66 S:Q ^PS(53.45,Y,0)="^53.450"_Y_"P^"_Q_U_Q
67 Q
68OC55 ;* Order checks for Speed finish and regular finish
69 N INTERVEN,PSJDDI,PSJIREQ,PSJRXREQ,PSJPDRG
70 S Y=1,(PSJIREQ,PSJRXREQ,INTERVEN,X)=""
71 K PSGORQF D ENDDC^PSGSICHK(PSGP,+$G(^PS(55,PSGP,5,+PSGORD,1,1,0)))
72 I '$D(PSGORQF) K PSGORQF,^TMP($J,"DI") D
73 . F PSGDDI=1:0 S PSGDDI=$O(^PS(55,PSGP,5,+PSGORD,1,PSGDDI)) Q:'PSGDDI S PSJDD=+$G(^PS(55,PSGP,5,+PSGORD,1,PSGDDI,0)) K PSJPDRG D IVSOL^PSGSICHK
74 Q
75UPDREN(PSGORD,RNWDT,PSGOEPR,PSGOFD,PSJNOO,RDUZ) ; update renewed order
76 N DR,DA,DIC,DIE,DD,DO,PSGRZERO,PSGRFOUR,PSGOORD
77 S DR="",PSGOEENO=0,PSGOORD=PSGORD,PSGNESD=PSGSD Q:'PSGORD!'RNWDT!'PSGOEPR!'PSGOFD S PSJNOO=$S($G(PSJNOO)]"":$G(PSJNOO),1:"E")
78 S PSGRZERO="^PS(55,"_PSGP_",5,"_+PSGORD_",0)",PSGOEORD=$P(@PSGRZERO,"^",21)
79 ; PSJ*5*141 - changed PSGOEPR to PSGPR for field 1 of the DR string below.
80 S DA(1)=PSGP,DA=+PSGORD,DIE="^PS(55,"_PSGP_",5," S DR="34////^S X=PSGFD" S:$G(PSGPR) DR=DR_";1////"_PSGPR_";110////"_PSJNOO D ^DIE
81 K DR,DA,DIC,DIE,DD,DO S DIC="^PS(55,"_PSGP_",5,"_+PSGORD_",14,",DIC(0)="L",DIC("P")="55.6114DA",ND14=$G(@(DIC_"0)")),DINUM=$P(ND14,"^",3)+1,DA(2)=PSGP,DA(1)=+PSGORD D
82 . S DIC("DR")=".01////"_$G(RNWDT)_";1////"_$S($G(RDUZ):RDUZ,1:$G(DUZ))_";2////"_$G(PSGOEPR)_";3////"_$G(PSGOFD)_";4////"_+PSGOEORD,X=$G(RNWDT) D FILE^DICN
83 K DR,DA,DIC,DIE,DD,DO S DA(1)=PSGP,DA=+PSGORD,DIE="^PS(55,"_PSGP_",5,",DR="28////A;105////@;107////@"
84 S PSGRFOUR="^PS(55,"_PSGP_",5,"_+PSGORD_",0)",PSGRFOUR=@PSGRFOUR I $P(PSGRFOUR,"^",2)<RNWDT S DR=DR_";16////@;17////@"
85 I '$G(PSJSPEED) I $G(PSGAT)]"",$G(PSGAT)'=$P($G(@(DIE_+PSGORD_",2)")),"^",5) S DR=DR_";41////"_PSGAT
86 D ^DIE
87 Q
88UPDRENOE(PSGP,PSGORD,RDATE) ;
89 D EXPOE(PSGP,PSGORD,$G(RDATE)) ; expire original Orders File order
90 I PSGORD'["P" K DA,DR,DIE S DA(1)=DFN,DA=+PSGORD,DIE="^PS(55,"_DFN_$S(PSGORD="U":",5,",1:",""IV"","),DR=$S(DIE["IV":110,1:66)_"////@" D ^DIE
91 D ENUDTX^PSJOREN(PSGP,PSGORD,"NR")
92 D EN1^PSJHL2(PSGP,"SN",PSGORD,"ORDER RENEWED")
93 Q
94READ ; hold screen
95 I $D(IOST) Q:$E(IOST)'="C"
96 W !?5,"Press return to continue " R X:$S($D(DTIME):DTIME,1:300)
97 Q
98EXPOE(DFN,PSJORDER,EXPDT) ; expire old Orders File entry
99 I PSJORDER["P" S FILE="^PS(53.1,"_+PSJORDER_",0)",PSJORDER=$P(@FILE,"^",25)
100 I (PSJORDER'["U"),(PSJORDER'["V") Q
101 N CURDAT D NOW^%DTC S CURDAT=$$DATE2^PSJUTL2(%)
102 S PSJEXPOE=$S($G(EXPDT):EXPDT,1:CURDAT) D EN1^PSJHL2(DFN,"SC",PSJORDER) K PSJEXPOE
103 Q
104EXPIRED(PSJX,PSJY) ;
105 ; INPUT
106 ; PSJX - Pharmacy Patient, pointer to ^PS(55
107 ; PSJY - Inpatient Order Number, pointer to IV or UD multiple of Pharmacy Patient file (appended with "V" or "U")
108 ; OUTPUT
109 ; 0 - Order has not exceeded the Expired Time Limit
110 ; 1 - Order has exceeded the Expired Time Limit
111 N STOP,STATUS,NOW,CUTOFF,FREQ,LAST,ST,X,DFN,U,PSGDT,SD,WD,PSJPSTO,PSGDW,PSGOC,ZZND,LASTAT,LSTSTR,PSBCNT S DFN=PSJX,U="^",CUTOFF=0
112 S STATUS=$S(PSJY["U":$P($G(^PS(55,PSJX,5,+PSJY,0)),"^",9),PSJY["V":$P($G(^PS(55,PSJX,"IV",+PSJY,0)),"^",17),1:"")
113 S NOW=$S($G(PSGDT):PSGDT,1:$$DATE^PSJUTL2())
114 S STOP=$S(PSJY["U":$P($G(^PS(55,PSJX,5,+PSJY,2)),U,4),1:$P($G(^PS(55,PSJX,"IV",+PSJY,0)),"^",3))
115 I NOW<STOP Q 0
116 I PSJY["U" N ND2,ND0 S ND0=$G(^PS(55,PSJX,5,+PSJY,0)),ND2=$G(^PS(55,PSJX,5,+PSJY,2)),FREQ=$P(ND2,"^",6) D
117 .N SCHED S SCHED=$P($G(^PS(55,PSJX,5,+PSJY,2)),"^") I SCHED["PRN" S FREQ=$$PRNFREQ(SCHED)
118 .S LSTSTR=$P(ND2,"^",2)_"^"_$P(ND2,"^",4)_"^"_SCHED_"^"_$P(ND0,"^",7)_"^^"_$P(ND2,"^",5)
119 .S LAST=$$EN^PSBAPIPM(PSJX,PSJY) I LAST,($P(ND0,"^",7)="O"),($P(LAST,"^",3)="G") I LAST>$P(ND2,"^",2) S CUTOFF=$$FMADD^XLFDT(NOW,,-1) Q
120 .I 'LAST!(LAST>$P(ND2,"^",4)) S LAST=$$LASTAT^PSJORP2(DFN,LSTSTR) S:LAST CUTOFF=$$FMADD^XLFDT(LAST,,,FREQ) Q
121 .I SCHED["PRN",($P(LSTSTR,"^",6)="") S CUTOFF=$$FMADD^XLFDT(LAST,,,FREQ) Q
122 .I $$DOW^PSIVUTL(SCHED) S CUTOFF=$$NXTDOW(DFN,$P(LSTSTR,"^"),$P(LSTSTR,"^",2),$P(LSTSTR,"^",3),$P(LSTSTR,"^",6)) Q
123 .S LAST=$$EN^PSBAPIPM(PSJX,PSJY) I 'LAST!(LAST>$P(ND2,"^",4)) S CUTOFF=$$FMADD^XLFDT(NOW,,-1) Q
124 .S $P(LSTSTR,"^")=$$FMADD^XLFDT(LAST,,,,1),$P(LSTSTR,"^",2)=$$FMADD^XLFDT(PSGDT,,,FREQ) S CUTOFF=$$ENQ^PSJORP2(PSJX,LSTSTR)
125 I PSJY["V" N LIMIT S LIMIT=$P($G(^PS(59.7,1,31)),"^",4) S LIMIT=$S((LIMIT]""):+LIMIT,1:24) S CUTOFF=$$FMADD^XLFDT(STOP,,LIMIT) D
126 .I '($G(P(4))]"") N P,YP,XP S YP=$G(^PS(55,DFN,"IV",+PSJY,0)) F XP=1:1:23 S P(XP)=$P(YP,U,XP)
127 .Q:'($G(P(4))]"")
128 .Q:'$$SCHREQ^PSJLIVFD(.P)
129 .N INTERVAL,LSTSTR,ND0,SCHED,IVSTYP S ND0=$G(^PS(55,PSJX,"IV",+PSJY,0)),INTERVAL=$P(ND0,"^",15),SCHED=$P(ND0,"^",9) Q:SCHED=""
130 .S IVSTYP=$S($$DOW^PSIVUTL(SCHED):"D",INTERVAL="O":"O",1:"C"),LSTSTR=$P(ND0,"^",2)_"^"_$P(ND0,"^",3)_"^"_SCHED_"^"_IVSTYP_"^^"_$P(ND0,"^",11)
131 .S LAST=$$EN^PSBAPIPM(PSJX,PSJY) I LAST,IVSTYP="O",LAST>$P(ND0,"^",2),($P(LAST,"^",3)="G") S CUTOFF=$$FMADD^XLFDT(NOW,,-1) Q
132 .I 'LAST!(LAST>$P(ND0,"^",3))!(LAST&(IVSTYP="O")) S CUTOFF=$$FMADD^XLFDT(NOW,,-1) Q
133 .I IVSTYP="D" S CUTOFF=$$NXTDOW(LAST,SCHED,$G(P(2)),$P($G(P(9)),"@"),$G(P(11))) Q
134 .I SCHED["PRN" S FREQ=$$PRNFREQ(SCHED) S CUTOFF=$$FMADD^XLFDT(LAST,,,FREQ) Q
135 .S LAST=$$EN^PSBAPIPM(PSJX,PSJY) I 'LAST!(LAST>$P(ND0,"^",3)) S CUTOFF=$$FMADD^XLFDT(NOW,,-1) Q
136 .S $P(LSTSTR,"^")=$$FMADD^XLFDT(LAST,,,,1),$P(LSTSTR,"^",2)=$$FMADD^XLFDT(PSGDT,31) S CUTOFF=$$ENQ^PSJORP2(PSJX,LSTSTR)
137 K LYN,PSBDT,PSBFLAG,PSBSTR
138 Q $S(CUTOFF<NOW:1,1:0)
139 ;
140NXTDOW(DOWDFN,DOWSD,DOWFD,DOWSCH,DOWAT) ;
141 N NXTADM,DOWSTR S DOWSTR=$$FMADD^XLFDT(DOWFD,,,,1)_"^"_$$FMADD^XLFDT(DOWFD,7)_"^"_DOWSCH_"^D^^"_DOWAT S NXTADM=$$ENQ^PSJORP2(DOWDFN,DOWSTR)
142 Q $S(NXTADM:NXTADM,1:DOWSD)
143 ;
144PRNFREQ(SCHED) ;
145 N ZZND,D,DA,X,PSGAT,PSGOES,PSGST,PSJNSS,PSJPWD,TEST,VALMBCK,PSGS0XT,PSGS0Y,PSGDT
146 F X=$P(SCHED,"PRN"),$P(SCHED,"PRN",2),$P(SCHED," PRN"),$P(SCHED,"PRN ",2) Q:$P($G(ZZND),"^",4) D ADMIN^PSJORPOE
147 Q $S($G(PSGS0XT):PSGS0XT,1:1440)
Note: See TracBrowser for help on using the repository browser.