source: FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOERS.m@ 1742

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

initial load of FOIAVistA 6/30/08 version
File size: 6.6 KB
Line 
1PSGOERS ;BIR/CML3-RENEW SELECTED ORDERS ;05 DEC 97 / 8:42 AM
2 ;;5.0; INPATIENT MEDICATIONS ;**11,29,35,47,58,110**;16 DEC 97
3 ;
4 ; Reference to ^PS(50.7 is supported by DBIA 2180
5 ; Reference to ^PS(55 is supported by DBIA 2191
6 ; Reference to ^PSDRUG( is supported by DBIA 2192
7 ; Reference to ^PSSLOCK is supported by DBIA 2789
8 ; Reference to NOW^%DTC is supported by DBIA 10000
9 ;
10MARK ; only mark order, not actually renew
11 W !,"...marking ",PSGPDRGN," ",PSGDO,"..." S $P(^PS(55,PSGP,5,+PSGORD,4),"^",15,17)="1^"_DUZ_"^"_PSGDT,PSGAL("C")=13180 D ^PSGAL5 W "."
12 I $D(PSJSYSO) S PSGPOSA="R",PSGPOSD=PSGDT,PSGORD=+PSGORD_"A" D ENPOS^PSGVDS
13 Q
14RENEW ; mark or renew order
15 D NOW^%DTC K DA S DA(1)=PSGP,DA=+PSGORD,PSGDT=+$E(%,1,12)
16 ; do order checking
17 N PSJABT,PSGDRG ;* S PSGDRG=$P($G(^PS(55,PSGP,5,+PSGORD,1,1,0)),"^")
18 ;* K PSGORQF D ENDDC^PSGSICHK(PSGP,+PSGDRG)
19 D OC55^PSGOER
20 I $D(PSGORQF) W !!," ",PSGOERS2,". ",$P($$DRUGNAME^PSJLMUTL(PSGP,PSGORD),"^")," ",$P(^PS(55,PSGP,5,+PSGORD,.2),"^",2),!,"...No action taken on this order...",! Q
21 ;* Q:$D(PSGORQF) ; quit if not to continue
22 ;
23 S PSGOER1=$G(^PS(55,PSGP,5,+PSGORD,.2)),PSGDO=$P(PSGOER1,"^",2),PSGPDRG=$P(PSGOER1,"^"),PSGPDRGN=$$ENPDN^PSGMI(PSGPDRG) I '$P(PSJSYSP0,"^",3) G MARK
24 S PSGOER0=$G(^PS(55,PSGP,5,+PSGORD,0)),PSGST=$P(PSGOER0,"^",7),PSGOER2=$G(^(2)),PSGND4=$G(^(4)),PSGSI=$G(^(6)),PSGOSD=$P(PSGOER2,"^",2),PSGOFD=$P(PSGOER2,"^",4),PSGNEDFD=$P($$GTNEDFD^PSGOE7("U",PSGPDRG),U)_"^^"_PSGST
25 N PSGOEAV S PSGOEAV=1,PSGOORD=PSGORD W "." K ^PS(53.45,PSJSYSP,1),^(2)
26 I $$CHKDD() W !!,"...",PSGPDRGN," ",PSGDO," order NOT renewed..." Q
27 W !!,"...renewing ",PSGOERS2,". ",PSGPDRGN," ",PSGDO,"..."
28 S PSGMR=$P(PSGOER0,"^",3),PSGMRN=$$ENMRN^PSGMI(PSGMR),PSGSM=$P(PSGOER0,"^",5),PSGHSM=$P(PSGOER0,"^",6),PSGPDRG=$P(PSGOER1,"^"),PSGDO=$P(PSGOER1,"^",2)
29 S PSGSCH=$P(PSGOER2,"^"),PSGS0Y=$P(PSGOER2,"^",5),PSGS0XT=$P(PSGOER2,"^",6),PSGNESD=PSGSD,PSGNEFD=$S(PSGST="O":PSGSD,1:PSGFD)
30 S:PSJPWD'=$P(PSGOER2,U,10) PSGS0Y=$$ENRNAT^PSGOU($P(PSGOER2,U,10),+PSJPWD,PSGSCH,PSGS0Y)
31 ;K ^PS(53.45,PSJSYSP,4) S Q=0 F S Q=$O(^PS(55,PSGP,5,+PSGORD,12,Q)) Q:'Q S ^PS(53.45,PSJSYSP,4,Q,0)=$G(^(Q,0))
32 I $O(^PS(55,PSGP,5,+PSGORD,3,0)) S ^PS(53.45,PSJSYSP,1,0)=^(0),Q=0 F S Q=$O(^PS(55,PSGP,5,+PSGORD,3,Q)) Q:'Q S ^PS(53.45,PSJSYSP,1,Q,0)=$G(^(Q,0))
33 I '$O(^PS(53.45,PSJSYSP,2,0)) D
34 .S X=$O(^PS(55,PSGP,5,+PSGORD,1,0)) I X S (Q,Q1)=0 F S Q=$O(^PS(55,PSGP,5,+PSGORD,1,Q)) Q:'Q S ND=$G(^(Q,0)) I ND,$S('$P(ND,"^",3):1,1:$P(ND,"^",3)>DT) S Q1=Q1+1,^PS(53.45,PSJSYSP,2,Q1,0)=$P(ND,"^",1,3)
35 D SPEED^PSGOER
36 ; PSGP,PSGORD) D UPDREN(PSGORD,PSGDT,PSGOEPR,PSGOFD,PSJNOO),UPDRENOE(PSGP,PSGORD,PSGDT
37 ;S:$S(X:Q1,1:0) ^PS(53.45,PSJSYSP,2,0)="^53.4502P^"_Q1_"^"_Q1 D ^PSGOETO I +PSJSYSU=3,PSGOORD["O" D EN^PSGPEN(+PSGORD)
38 ;W !,"...updating original order...",! K DA S DA(1)=PSGP,DA=+PSGOORD,PSGAL("C")=PSJSYSU*10+18000 D ^PSGAL5
39 ;I PSGORD'["O",PSGSD<PSGOFD S PSGALR=70,DIE="^PS(55,"_PSGP_",5,",DR="34////"_+PSGSD S:PSGSD'>PSGDT DR=DR_";28////E"
40 ;I D ^DIE I $P($G(^PS(55,PSGP,5,+PSGOORD,0)),"^",21) D EN1^PSJHL2(PSGP,"SC",PSGOORD,"ORDER EXPIRED")
41 ;S $P(PSGND4,"^",12,14)="^^",$P(PSGND4,"^",15,20)="^^^^^",$P(PSGND4,"^",22,24)="^^",^PS(55,PSGP,5,+PSGOORD,4)=PSGND4,$P(^(0),"^",26,27)=PSGORD_"^R"
42 Q
43CHKDD() ;
44 I '$$CHKDD^PSGOE2("^PS(55,"_PSGP_",5,"_+PSGORD_",") Q 0
45 I $P(PSJSYSU,";")'=3,'$P(PSJSYSP0,U,2) W !!,"This order's dispense drug is invalid, a pharmacist must renew this order." Q 1
46 W !!,"THE DISPENSE DRUG IS MISSING FROM THIS ORDER."
47 D ENDRG^PSGOEF1(+^PS(55,PSGP,5,+PSGORD,.2),0)
48 I $G(DUOUT) W !,"ORDER NOT RENEW."
49 Q $G(DUOUT)!'$G(DRG)
50EN ;
51 Q:'$$HIDDEN^PSJLMUTL("SPEED") S PSJSPEED=1
52 N PSGONR,CODE,ST,DRG,ON S PSGOEORF=1 D FULL^VALM1
53 S CODE="",PSGONR=0 F S CODE=$O(^TMP("PSJ",$J,CODE)) Q:CODE'="A" D
54 .S ST="" F S ST=$O(^TMP("PSJ",$J,CODE,ST)) Q:ST="" D
55 ..S DRG="" F S DRG=$O(^TMP("PSJ",$J,CODE,ST,DRG)) Q:DRG="" S ON="" F S ON=$O(^TMP("PSJ",$J,CODE,ST,DRG,ON)) Q:ON="" S PSGONR=PSGONR+1
56 S PSGONW="R",PSGLMT=PSGONR D ENWO^PSGON I "^"[X K X G DONE
57 S PSGOSD=0 F PSGOERS=1:1:PSGODDD F PSGOERS1=1:1 S PSGOERS2=$P(PSGODDD(PSGOERS),",",PSGOERS1) Q:'PSGOERS2 S Y=+^TMP("PSJON",$J,PSGOERS2),F=$G(^PS(55,PSGP,5,Y,0)),D=$G(^(.2)) D HMSG I F G EN
58 I $P(PSJSYSP0,"^",3) D I '$D(PSGFOK) S X="" G DONE
59 .NEW PSGRENEW S PSGRENEW=1
60 .S PSGORD=^TMP("PSJON",$J,+PSGODDD(1)),DA=+PSGORD,DA(1)=PSGP,PSGWLL=$S($P(PSJSYSW0,"^",4):+$G(^PS(55,PSGP,5.1)),1:0),PSGOEE="R" W ! D DATE^PSGOER0(PSGP,PSGORD,PSGDT)
61 .I '$D(PSGFOK(106)) W $C(7),!,"...order",$E("s",$L(PSGODDD(1),",")>2)," NOT renewed..." K PSGFOK Q
62 .I 'PSGNEDFD,$P(PSJSYSW0,"^",4),PSGFD'<PSGWLL S $P(^PS(55,PSGP,5.1),"^")=+PSGFD
63 ;W ! F PSGOERS=1:1:PSGODDD F PSGOERS1=1:1 S PSGOERS2=$P(PSGODDD(PSGOERS),",",PSGOERS1) Q:'PSGOERS2 S PSGORD=^TMP("PSJON",$J,PSGOERS2) D RENEW
64 W !
65 S EXITLOOP=0
66 F PSGOERS=1:1:PSGODDD D
67 .F PSGOERS1=1:1 D Q:EXITLOOP=1
68 ..S PSGOERS2=$P(PSGODDD(PSGOERS),",",PSGOERS1)
69 ..I 'PSGOERS2 S EXITLOOP=1 Q
70 ..S PSGORD=^TMP("PSJON",$J,PSGOERS2)
71 ..I $$CHKCOM Q
72 ..I '$$LS^PSSLOCK(DFN,PSGORD) W !,$P($$DRUGNAME^PSJLMUTL(DFN,PSGORD),"^",1),!,"NO ACTION WAS TAKEN",!,$C(7) HANG 1 Q
73 ..D RENEW
74 ..; Call the unlock procedure
75 ..D UNL^PSSLOCK(DFN,PSGORD)
76 ..I $G(PSGOORD) D UNL^PSSLOCK(DFN,PSGOORD)
77 S X=""
78DONE ;
79 D INIT^PSJLMHED(1)
80 K DA,DIE,DR,FDSD,PSGAL,PSGALR,PSGFD,PSGFOK,PSGLMT,PSGND4,PSGODDD,PSGOERS,PSGOERS1,PSGOERS2,PSGONW,PSGOPR,PSGORD,PSGOSD,PSGPOSA,PSGPOSD,PSGPR,PSGPX,PSGSD,PSGST,PSGTOL,PSGTOO,PSGUOW,PSGWLL,PSJSPEED
81 Q
82GRI ; get renewal info
83HMSG ; hold/'not to be given' message
84 S X=$P($G(^PS(50.7,+D,0)),"^") S:X]"" X=X_" "_$P(D,"^",2)
85 I $P(F,"^",22) S H="has been marked as 'NOT TO BE GIVEN'" D WO Q
86 I $P(F,"^",9)="H" S H="is ON HOLD" D WO Q
87 I $P(F,"^",27)]"",$P(F,"^",26) S H="has been "_$S($P(F,"^",24)="E":"EDITED",1:"RENEWED") D WO Q
88 I ($P($G(^PS(50.7,+D,0)),"^",4)]"")&($P($G(^(0)),"^",4)'>DT) S H="is no longer an active Orderable Item" D WO Q
89 N PSGDFLG,DRG,DRGPT
90 S PSGDFLG=1 F DRG=0:0 S DRG=$O(^PSDRUG("ASP",+D,DRG)) Q:'DRG I $P(^PSDRUG(DRG,2),U,3)["U",($G(^PSDRUG(DRG,"I"))=""!($G(^("I"))>DT)) S PSGDFLG=0 Q
91 I PSGDFLG S H="is no longer an active Dispense drug" D WO Q
92 S F=0,X=$P($G(^PS(55,PSGP,5,Y,2)),"^",2) S:X>PSGOSD PSGOSD=X Q
93WO ;
94 W $C(7)," ??",! W:X]"" !,X S H1="Order number "_$G(PSGOERS2)_" "_H_", and cannot be renewed." W ! F H2=1:1:$L(H1," ") S H3=$P(H1," ",H2) W:$L(H3)+$X>78 ! W H3," "
95 S F=1 K H,H1,H2,H3 Q
96CHKCOM() ; Check if this order is a complex order
97 S PSJCOM=0
98 I PSGORD=+PSGORD S PSJCOM=PSGORD W !," Order ",PSGOERS2," is part of a complex order series, and cannot be renewed.",! H 2 Q PSJCOM
99 S PSJCOM=$S(PSGORD["U":$P($G(^PS(55,PSGP,5,+PSGORD,.2)),U,8),1:$P($G(^PS(53.1,+PSGORD,.2)),U,8))
100 I PSJCOM W !," Order ",PSGOERS2," is part of a complex order series, and cannot be renewed.",! H 2
101 Q PSJCOM
Note: See TracBrowser for help on using the repository browser.