- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORUT2.m
r613 r623 1 PSJORUT2 ;BIR/MLM-MISC. PROCEDURE CALLS FOR OE/RR 3.0 (CONT.) ;03 Aug 98 / 8:42 AM 2 ;;5.0; INPATIENT MEDICATIONS ;**14,29,50,56,58,107,152,134**;16 DEC 97;Build 124 3 ; 4 ; Reference to ^PS(55 is supported by DBIA 2191 5 ; Reference to ^PS(50.605 is supported by DBIA 2138,696. 6 ; References to ^PS(52.6 supported by DBIA 1231 7 ; Reference to ^PS(52.7 supported by DBIA 2173. 8 ; Reference to ^PSDRUG( is supported by DBIA 2192 9 ; Reference to ^PSNDF( is supported by DBIA 2195 10 ; Reference to ^PSRX( is supported by DBIA 824 11 ; Reference to ^PSNAPIS is supported by DBIA 2531 12 ; 13 ENVAC(PN) ; Find VA CLASS of VA Product Name 14 ;Input: PN - See above 15 ;Output: VA Drug Class^Classification 16 ; 17 ; NEW NDF CALL 18 N X S X="PSNAPIS" X ^%ZOSF("TEST") I N PSJC,X1,X2 S X1=+$P(PN,"."),X2=+$P(PN,".",2),PSJC=$$DCLASS^PSNAPIS(X1,X2) Q PSJC 19 ; 20 N GDP,PNP S GDP=$P(PN,"."),PNP=$P(PN,".",2) 21 S X=+$P($G(^PSNDF(+GDP,5,+PNP,0)),U,2),X=+$P($G(^PSNDF(GDP,2,X,0)),U,3),PSJC=$P($G(^PS(50.605,X,0)),U,2) 22 Q $S('X:0,PSJC="":0,1:X_U_PSJC) 23 ; 24 ENVAGN(PN) ; Return VA Generic Name for specified VA Product Name. 25 ;Input: PN - VA Product Name IEN 26 ;Output: VA Generic Name IEN^VA Generic Name 27 ; 28 ; NEW NDF CALL 29 N X S X="PSNAPIS" X ^%ZOSF("TEST") I N GDP,X1,X2 S X1=+$P(PN,"."),X2=+$P(PN,".",2),GDP=$$VAGN^PSNAPIS(X1) Q $S(GDP=0:0,1:X1_U_GDP) 30 ; 31 N GDP,PNP S GDP=+$P(PN,"."),PNP=+$P(PN,".",2) 32 S X=$P($G(^PSNDF(GDP,0)),U) 33 Q $S('GDP:0,X="":0,1:GDP_U_X) 34 ENVOL(PN,ARRAY) ; 35 I (PN'["A")&(PN'["B") S ARRAY="0" Q 36 N X,XX,F,INACT,IVFL 37 S X(1)="ML",X(2)="LITER",X(3)="MCG",X(4)="MG",X(5)="GM",X(6)="UNITS",X(7)="IU",X(8)="MEQ",X(9)="MM",X(10)="MU",X(11)="THOUU",X(12)="MG-PE",X(13)="NANOGRAM",X(14)="MMOL" 38 I PN["A" N ADD S (ADD,X,XX)=0 F S ADD=$O(^PS(52.6,"AOI",+PN,ADD)) Q:ADD="" D 39 .S INACT=$G(^PS(52.6,ADD,"I")) I INACT']""!(INACT>DT) S IVFL=$P($G(^(0)),"^",13) Q:'IVFL S XX=XX+1,ARRAY(ADD)="^"_X($P($G(^PS(52.6,ADD,0)),U,3)) Q 40 I PN["B" N SOL S SOL=0,XX=0 F S SOL=$O(^PS(52.7,"AOI",+PN,SOL)) Q:SOL="" D 41 .S INACT=$G(^PS(52.7,SOL,"I")) I INACT']""!(INACT>DT) S IVFL=$P($G(^(0)),"^",13) Q:'IVFL S XX=XX+1,ARRAY(SOL)=$P($G(^PS(52.7,SOL,0)),"^",3) 42 S ARRAY=XX>0 43 Q 44 ; 45 ENVOL2(PN,ARRAY) ;Only for Med Button IV orders. 46 I (PN'["A")&(PN'["B") S ARRAY="0" Q 47 N X,XX,F,INACT 48 S X(1)="ML",X(2)="LITER",X(3)="MCG",X(4)="MG",X(5)="GM",X(6)="UNITS",X(7)="IU",X(8)="MEQ",X(9)="MM",X(10)="MU",X(11)="THOUU",X(12)="MG-PE",X(13)="NANOGRAM",X(14)="MMOL" 49 I PN["A" N ADD S (ADD,X,XX)=0 F S ADD=$O(^PS(52.6,"AOI",+PN,ADD)) Q:ADD="" D 50 .S INACT=$G(^PS(52.6,ADD,"I")) I INACT']""!(INACT>DT) S XX=XX+1,ARRAY(ADD)="^"_X($P($G(^PS(52.6,ADD,0)),U,3)) Q 51 I PN["B" N SOL S SOL=0,XX=0 F S SOL=$O(^PS(52.7,"AOI",+PN,SOL)) Q:SOL="" D 52 .S INACT=$G(^PS(52.7,SOL,"I")) I INACT']""!(INACT>DT) S XX=XX+1,ARRAY(SOL)=$P($G(^PS(52.7,SOL,0)),"^",3) 53 S ARRAY=XX>0 54 Q 55 ; 56 ; 57 SENVOL(PN,PSJ) ;Return array listing volume (base only) and volume units for the specified additive or solution. 58 ;Input: PN - IEN_B (Base) or A (Additive) 59 ;Output: ARRAY(IEN,A:additive or B:Base)=volume^volume units 60 ; If no volume or units found PSJ=0; If found PSJ=1. 61 ; 62 N X S PSJ=1 63 S X(1)="ML",X(2)="LITER",X(3)="MCG",X(4)="MG",X(5)="GM",X(6)="UNITS",X(7)="IU",X(8)="MEQ",X(9)="MM",X(10)="MU",X(11)="THOUU",X(12)="MG-PE",X(13)="NANOGRAM",X(14)="MMOL" 64 I PN'["A",PN'["B" S PSJ=0 Q 65 S PSJ=PSJ+1 66 I PN["A" S PSJ(+PN,"A")=U_X(+$P($G(^PS(52.6,+PN,0)),U,3)) Q 67 I PN["B" S PSJ(+PN,"B")=+$P($G(^PS(52.7,+PN,0)),U,3)_U_X(1) Q 68 Q 69 ; 70 ENREF(PRX) ; Return number of refills remaining. 71 ;Input: PRX - Internal prescription number from File #52. 72 ;Output: Number of refills remaining. 73 ; 74 N X,COUNT,CNT S PRX=$P(PRX,"^"),COUNT=0,X=$P(^PSRX(PRX,0),"^",9) 75 D:$O(^PSRX(PRX,1,0)) 76 .F CNT=0:0 S CNT=$O(^PSRX(PRX,1,CNT)) Q:'CNT S COUNT=COUNT+1 77 S:$G(COUNT) X=X-COUNT 78 Q X 79 ; 80 ENCHK(DFN,PSJINX) ; Return dispense drug check array. 81 ;Input: DFN - Patient internal entry number 82 ; PSJINX - Index number so duplicate drugs will be returned. 83 ; PSGOCHK - Check should include dispense drugs in 53.45 84 ; PSIVOCHK - Check should include entries in DRG array 85 ;Output: ^TMP($J,"ORDERS",PSJINX)=DRUG CLASS^NATIONAL DRUG FILE ENTRY 86 ; _"A"_PSNDFA PRODUCT NAME ENTRY_DISPENSE DRUG NAME^OE/RR # 87 ; _ORDER NUMBER(P/I/V)_";I" 88 ; 89 NEW BDT,DDRUG,DDRUG0,DDRUGND,EDT,F,ON,ON1,PST,WBDT,X,PSJORIEN 90 D NOW^%DTC S (BDT,WBDT)=%,EDT=9999999 91 S F="^PS(55,DFN,5," F S WBDT=$O(^PS(55,DFN,5,"AUS",WBDT)) Q:'WBDT F ON=0:0 S ON=$O(^PS(55,DFN,5,"AUS",WBDT,ON)) Q:'ON D UD 92 S F="^PS(53.1," F PST="P","N" F ON=0:0 S ON=$O(^PS(53.1,"AS",PST,DFN,ON)) Q:'ON D 93 . I $O(^PS(53.1,+ON,"AD",0))!$O(^PS(53.1,+ON,"SOL",0)) D PIV Q 94 . D UD 95 S WBDT=BDT F S WBDT=$O(^PS(55,DFN,"IV","AIS",WBDT)) Q:'WBDT F ON=0:0 S ON=$O(^PS(55,DFN,"IV","AIS",WBDT,ON)) Q:'ON D IV 96 I '$G(PSIVOCON) D NEWIV ; Don't do this when Finishing orders (FN) 97 Q 98 UD ;*** Get the dispense drugs for the Unit Dose orders. 99 S PSJORIEN=$P(@(F_ON_",0)"),U,21),DDRUG=0 100 I F="^PS(53.1,",($P(@(F_ON_",0)"),U,4)="I") D Q 101 . NEW PSJPD S COD=ON_"P" 102 . S PSJPD=+$G(^PS(53.1,ON,.2)) D:$D(^PS(52.6,"AOI",PSJPD)) ENDDIV^PSJORUTL(PSJPD,"A","",.DDRUG) S DDRUG=+DDRUG D:DDRUG DDRUG 103 S ON1=0 F S ON1=$O(@(F_ON_",1,"_ON1_")")) Q:'ON1 S DDRUG=@(F_ON_",1,"_ON1_",0)") I $P(DDRUG,U,3)=""!($P(DDRUG,U,3)>BDT) S COD=ON_$S(F["^PS(53.1":"P",1:"U") D DDRUG 104 I $D(PSGOCHK) F ON1=0:0 S ON1=$O(^PS(53.45,+PSJSYSP,1,ON1)) Q:'ON1 S DDRUG=$G(^PS(53.45,+PSJSYSP,1,ON1,0)) I $P(DDRUG,U,3)=""!@($P(DDRUG,U,3)>BDT) S (COD,PSJORIEN)="" D DDRUG 105 I '$O(@(F_ON_",1,"_0_")")) N OI S OI=+$G(@(F_ON_",.2)")) I OI D 106 .S DDRUG="" F S DDRUG=$O(^PSDRUG("ASP",OI,DDRUG)) Q:'DDRUG D 107 ..I ($P(DDRUG,U,3)=""!($P(DDRUG,U,3)>BDT)) S COD=ON_$S(F["^PS(53.1":"P",1:"U") D DDRUG 108 Q 109 PIV ;*** Get the dispense drugs for the Pending IV orders. 110 S X=^PS(53.1,+ON,0),PSJORIEN=$P(X,U,21) Q:$P(X,U,27)="R" 111 S ON1=0 F S ON1=$O(^PS(53.1,+ON,"AD",ON1)) Q:'ON1 S X=+^PS(53.1,+ON,"AD",ON1,0),DDRUG=$P($G(^PS(52.6,X,0)),U,2) S COD=+ON_"P" D DDRUG 112 S ON1=0 F S ON1=$O(^PS(53.1,+ON,"SOL",ON1)) Q:'ON1 S X=+^PS(53.1,+ON,"SOL",ON1,0),DDRUG=$P($G(^PS(52.7,X,0)),U,2) S COD=+ON_"P" D DDRUG 113 Q 114 IV ;*** Get the dispense drugs for the IV orders. 115 NEW X S X=^PS(55,DFN,"IV",ON,0),PSJORIEN=$P(X,U,21) Q:$P(X,U,17)="R" 116 S ON1=0 F S ON1=$O(^PS(55,DFN,"IV",ON,"AD",ON1)) Q:'ON1 S X=+^PS(55,DFN,"IV",ON,"AD",ON1,0),DDRUG=$P($G(^PS(52.6,X,0)),U,2) S COD=ON_"V" D DDRUG 117 S ON1=0 F S ON1=$O(^PS(55,DFN,"IV",ON,"SOL",ON1)) Q:'ON1 S X=+^PS(55,DFN,"IV",ON,"SOL",ON1,0),DDRUG=$P($G(^PS(52.7,X,0)),U,2) S COD=ON_"V" D DDRUG 118 Q 119 NEWIV ;*** Get the dispense drugs for the newly entered IV order. 120 NEW PSIVX,ON 121 S ON=$O(DRGOC(0)),PSJORIEN="" Q:'+ON 122 F PSIVX=0:0 S PSIVX=$O(DRGOC(ON,"AD",PSIVX)) Q:'PSIVX S DDRUG=$P(^PS(52.6,+DRGOC(ON,"AD",PSIVX),0),U,2),COD=ON55 D DDRUG 123 F PSIVX=0:0 S PSIVX=$O(DRGOC(ON,"SOL",PSIVX)) Q:'PSIVX S DDRUG=$P(^PS(52.7,+DRGOC(ON,"SOL",PSIVX),0),U,2),COD=ON D DDRUG 124 Q 125 DDRUG ;*** Set PSJ(DDRUG NAME) arrays. 126 Q:'DDRUG S DDRUG0=$G(^PSDRUG(+DDRUG,0)),DDRUGND=$G(^PSDRUG(+DDRUG,"ND")) 127 S PSJINX=+$G(PSJINX)+1 ;* ^PSOORDRG calls this entry point. 128 I $D(DDRUG)=11,DDRUG[";" D Q ; if called from ^PSOORDRG 129 .N IPOROP S IPOROP=$P(DDRUG,";",2) 130 .S IPOROP=$S(IPOROP="PSO":";O",IPOROP="PSH":"N;O",1:";I") 131 .S ^TMP($J,"ORDERS",PSJINX)=$P(DDRUG0,U,2)_U_$P(DDRUGND,U)_"A"_$P(DDRUGND,U,3)_U_$P(DDRUG0,U)_U_$S($G(DDRUG(DDRUG)):DDRUG(DDRUG),1:$G(PSJORIEN))_U_$G(COD)_IPOROP 132 S ^TMP($J,"ORDERS",PSJINX)=$P(DDRUG0,U,2)_U_$P(DDRUGND,U)_"A"_$P(DDRUGND,U,3)_U_$P(DDRUG0,U)_U_$G(PSJORIEN)_U_$G(COD)_";I" 133 Q 134 ; 135 PRCHK(PSJ) ; Check if authorized to write med orders. 136 N %,X 137 D NOW^%DTC S X=$G(^VA(200,PSJ,"PS")) I $S('X:1,'$P(%,"^",4):0,1:$P(X,"^",4)'>%) Q 0 138 Q PSJ 139 ; 140 ENNG(PSJDPT,PSJNUM) ; returns 1 if order marked "Not To Be Given" 141 ; 0 if not marked 142 I '$D(^PS(55,PSJDPT,5,+PSJNUM,0)) Q 0 143 I $P($G(^PS(55,PSJDPT,5,+PSJNUM,0)),"^",22)=1 Q 1 144 Q 0 1 PSJORUT2 ;BIR/MLM-MISC. PROCEDURE CALLS FOR OE/RR 3.0 (CONT.) ;03 Aug 98 / 8:42 AM 2 ;;5.0; INPATIENT MEDICATIONS ;**14,29,50,56,58,107,152**;16 DEC 97 3 ; 4 ; Reference to ^PS(55 is supported by DBIA 2191 5 ; Reference to ^PS(50.605 is supported by DBIA 2138 6 ; References to ^PS(52.6 supported by DBIA 1231 7 ; Reference to ^PS(52.7 supported by DBIA 2173. 8 ; Reference to ^PSDRUG( is supported by DBIA 2192 9 ; Reference to ^PSNDF( is supported by DBIA 2195 10 ; Reference to ^PSRX( is supported by DBIA 824 11 ; Reference to ^PSNAPIS is supported by DBIA 2531 12 ; 13 ENVAC(PN) ; Find VA CLASS of VA Product Name 14 ;Input: PN - See above 15 ;Output: VA Drug Class^Classification 16 ; 17 ; NEW NDF CALL 18 N X S X="PSNAPIS" X ^%ZOSF("TEST") I N PSJC,X1,X2 S X1=+$P(PN,"."),X2=+$P(PN,".",2),PSJC=$$DCLASS^PSNAPIS(X1,X2) Q PSJC 19 ; 20 N GDP,PNP S GDP=$P(PN,"."),PNP=$P(PN,".",2) 21 S X=+$P($G(^PSNDF(+GDP,5,+PNP,0)),U,2),X=+$P($G(^PSNDF(GDP,2,X,0)),U,3),PSJC=$P($G(^PS(50.605,X,0)),U,2) 22 Q $S('X:0,PSJC="":0,1:X_U_PSJC) 23 ; 24 ENVAGN(PN) ; Return VA Generic Name for specified VA Product Name. 25 ;Input: PN - VA Product Name IEN 26 ;Output: VA Generic Name IEN^VA Generic Name 27 ; 28 ; NEW NDF CALL 29 N X S X="PSNAPIS" X ^%ZOSF("TEST") I N GDP,X1,X2 S X1=+$P(PN,"."),X2=+$P(PN,".",2),GDP=$$VAGN^PSNAPIS(X1) Q $S(GDP=0:0,1:X1_U_GDP) 30 ; 31 N GDP,PNP S GDP=+$P(PN,"."),PNP=+$P(PN,".",2) 32 S X=$P($G(^PSNDF(GDP,0)),U) 33 Q $S('GDP:0,X="":0,1:GDP_U_X) 34 ENVOL(PN,ARRAY) ; 35 I (PN'["A")&(PN'["B") S ARRAY="0" Q 36 N X,XX,F,INACT,IVFL S X(1)="ML",X(2)="LITER",X(3)="MCG",X(4)="MG",X(5)="GM",X(6)="UNITS",X(7)="IU",X(8)="MEQ",X(9)="MM",X(10)="MU",X(11)="THOUU",X(12)="MG-PE",X(13)="NANOGRAM" 37 I PN["A" N ADD S (ADD,X,XX)=0 F S ADD=$O(^PS(52.6,"AOI",+PN,ADD)) Q:ADD="" D 38 .S INACT=$G(^PS(52.6,ADD,"I")) I INACT']""!(INACT>DT) S IVFL=$P($G(^(0)),"^",13) Q:'IVFL S XX=XX+1,ARRAY(ADD)="^"_X($P($G(^PS(52.6,ADD,0)),U,3)) Q 39 I PN["B" N SOL S SOL=0,XX=0 F S SOL=$O(^PS(52.7,"AOI",+PN,SOL)) Q:SOL="" D 40 .S INACT=$G(^PS(52.7,SOL,"I")) I INACT']""!(INACT>DT) S IVFL=$P($G(^(0)),"^",13) Q:'IVFL S XX=XX+1,ARRAY(SOL)=$P($G(^PS(52.7,SOL,0)),"^",3) 41 S ARRAY=XX>0 42 Q 43 ; 44 ENVOL2(PN,ARRAY) ;Only for Med Button IV orders. 45 I (PN'["A")&(PN'["B") S ARRAY="0" Q 46 N X,XX,F,INACT S X(1)="ML",X(2)="LITER",X(3)="MCG",X(4)="MG",X(5)="GM",X(6)="UNITS",X(7)="IU",X(8)="MEQ",X(9)="MM",X(10)="MU",X(11)="THOUU",X(12)="MG-PE",X(13)="NANOGRAM" 47 I PN["A" N ADD S (ADD,X,XX)=0 F S ADD=$O(^PS(52.6,"AOI",+PN,ADD)) Q:ADD="" D 48 .S INACT=$G(^PS(52.6,ADD,"I")) I INACT']""!(INACT>DT) S XX=XX+1,ARRAY(ADD)="^"_X($P($G(^PS(52.6,ADD,0)),U,3)) Q 49 I PN["B" N SOL S SOL=0,XX=0 F S SOL=$O(^PS(52.7,"AOI",+PN,SOL)) Q:SOL="" D 50 .S INACT=$G(^PS(52.7,SOL,"I")) I INACT']""!(INACT>DT) S XX=XX+1,ARRAY(SOL)=$P($G(^PS(52.7,SOL,0)),"^",3) 51 S ARRAY=XX>0 52 Q 53 ; 54 ; 55 SENVOL(PN,PSJ) ;Return array listing volume (base only) and volume units for the specified additive or solution. 56 ;Input: PN - IEN_B (Base) or A (Additive) 57 ;Output: ARRAY(IEN,A:additive or B:Base)=volume^volume units 58 ; If no volume or units found PSJ=0; If found PSJ=1. 59 ; 60 N X S PSJ=1,X(1)="ML",X(2)="LITER",X(3)="MCG",X(4)="MG",X(5)="GM",X(6)="UNITS",X(7)="IU",X(8)="MEQ",X(9)="MM",X(10)="MU",X(11)="THOUU",X(12)="MG-PE",X(13)="NANOGRAM" 61 I PN'["A",PN'["B" S PSJ=0 Q 62 S PSJ=PSJ+1 63 I PN["A" S PSJ(+PN,"A")=U_X(+$P($G(^PS(52.6,+PN,0)),U,3)) Q 64 I PN["B" S PSJ(+PN,"B")=+$P($G(^PS(52.7,+PN,0)),U,3)_U_X(1) Q 65 Q 66 ; 67 ENREF(PRX) ; Return number of refills remaining. 68 ;Input: PRX - Internal prescription number from File #52. 69 ;Output: Number of refills remaining. 70 ; 71 N X,COUNT,CNT S PRX=$P(PRX,"^"),COUNT=0,X=$P(^PSRX(PRX,0),"^",9) 72 D:$O(^PSRX(PRX,1,0)) 73 .F CNT=0:0 S CNT=$O(^PSRX(PRX,1,CNT)) Q:'CNT S COUNT=COUNT+1 74 S:$G(COUNT) X=X-COUNT 75 Q X 76 ; 77 ENCHK(DFN,PSJINX) ; Return dispense drug check array. 78 ;Input: DFN - Patient internal entry number 79 ; PSJINX - Index number so duplicate drugs will be returned. 80 ; PSGOCHK - Check should include dispense drugs in 53.45 81 ; PSIVOCHK - Check should include entries in DRG array 82 ;Output: ^TMP($J,"ORDERS",PSJINX)=DRUG CLASS^NATIONAL DRUG FILE ENTRY 83 ; _"A"_PSNDFA PRODUCT NAME ENTRY_DISPENSE DRUG NAME^OE/RR # 84 ; _ORDER NUMBER(P/I/V)_";I" 85 ; 86 NEW BDT,DDRUG,DDRUG0,DDRUGND,EDT,F,ON,ON1,PST,WBDT,X,PSJORIEN 87 ;* S BDT=DT,WBDT=BDT_".000001",EDT=9999999 88 D NOW^%DTC S (BDT,WBDT)=%,EDT=9999999 89 S F="^PS(55,DFN,5," F S WBDT=$O(^PS(55,DFN,5,"AUS",WBDT)) Q:'WBDT F ON=0:0 S ON=$O(^PS(55,DFN,5,"AUS",WBDT,ON)) Q:'ON D UD 90 S F="^PS(53.1," F PST="P","N" F ON=0:0 S ON=$O(^PS(53.1,"AS",PST,DFN,ON)) Q:'ON D 91 . I $O(^PS(53.1,+ON,"AD",0))!$O(^PS(53.1,+ON,"SOL",0)) D PIV Q 92 . D UD 93 S WBDT=BDT F S WBDT=$O(^PS(55,DFN,"IV","AIS",WBDT)) Q:'WBDT F ON=0:0 S ON=$O(^PS(55,DFN,"IV","AIS",WBDT,ON)) Q:'ON D IV 94 I '$G(PSIVOCON) D NEWIV ; Don't do this when Finishing orders (FN) 95 Q 96 UD ;*** Get the dispense drugs for the Unit Dose orders. 97 S PSJORIEN=$P(@(F_ON_",0)"),U,21),DDRUG=0 98 I F="^PS(53.1,",($P(@(F_ON_",0)"),U,4)="I") D Q 99 . NEW PSJPD S COD=ON_"P" 100 . S PSJPD=+$G(^PS(53.1,ON,.2)) D:$D(^PS(52.6,"AOI",PSJPD)) ENDDIV^PSJORUTL(PSJPD,"A","",.DDRUG) S DDRUG=+DDRUG D:DDRUG DDRUG 101 S ON1=0 F S ON1=$O(@(F_ON_",1,"_ON1_")")) Q:'ON1 S DDRUG=@(F_ON_",1,"_ON1_",0)") I $P(DDRUG,U,3)=""!($P(DDRUG,U,3)>BDT) S COD=ON_$S(F["^PS(53.1":"P",1:"U") D DDRUG 102 I $D(PSGOCHK) F ON1=0:0 S ON1=$O(^PS(53.45,+PSJSYSP,1,ON1)) Q:'ON1 S DDRUG=$G(^PS(53.45,+PSJSYSP,1,ON1,0)) I $P(DDRUG,U,3)=""!@($P(DDRUG,U,3)>BDT) S (COD,PSJORIEN)="" D DDRUG 103 I '$O(@(F_ON_",1,"_0_")")) N OI S OI=+$G(@(F_ON_",.2)")) I OI D 104 .S DDRUG="" F S DDRUG=$O(^PSDRUG("ASP",OI,DDRUG)) Q:'DDRUG D 105 ..I ($P(DDRUG,U,3)=""!($P(DDRUG,U,3)>BDT)) S COD=ON_$S(F["^PS(53.1":"P",1:"U") D DDRUG 106 Q 107 PIV ;*** Get the dispense drugs for the Pending IV orders. 108 S X=^PS(53.1,+ON,0),PSJORIEN=$P(X,U,21) Q:$P(X,U,27)="R" 109 S ON1=0 F S ON1=$O(^PS(53.1,+ON,"AD",ON1)) Q:'ON1 S X=+^PS(53.1,+ON,"AD",ON1,0),DDRUG=$P($G(^PS(52.6,X,0)),U,2) S COD=+ON_"P" D DDRUG 110 S ON1=0 F S ON1=$O(^PS(53.1,+ON,"SOL",ON1)) Q:'ON1 S X=+^PS(53.1,+ON,"SOL",ON1,0),DDRUG=$P($G(^PS(52.7,X,0)),U,2) S COD=+ON_"P" D DDRUG 111 Q 112 IV ;*** Get the dispense drugs for the IV orders. 113 NEW X S X=^PS(55,DFN,"IV",ON,0),PSJORIEN=$P(X,U,21) Q:$P(X,U,17)="R" 114 S ON1=0 F S ON1=$O(^PS(55,DFN,"IV",ON,"AD",ON1)) Q:'ON1 S X=+^PS(55,DFN,"IV",ON,"AD",ON1,0),DDRUG=$P($G(^PS(52.6,X,0)),U,2) S COD=ON_"V" D DDRUG 115 S ON1=0 F S ON1=$O(^PS(55,DFN,"IV",ON,"SOL",ON1)) Q:'ON1 S X=+^PS(55,DFN,"IV",ON,"SOL",ON1,0),DDRUG=$P($G(^PS(52.7,X,0)),U,2) S COD=ON_"V" D DDRUG 116 ;*D:$G(PSIVNEW) NEWIV 117 Q 118 NEWIV ;*** Get the dispense drugs for the newly entered IV order. 119 NEW PSIVX,ON 120 S ON=$O(DRGOC(0)),PSJORIEN="" Q:'+ON 121 F PSIVX=0:0 S PSIVX=$O(DRGOC(ON,"AD",PSIVX)) Q:'PSIVX S DDRUG=$P(^PS(52.6,+DRGOC(ON,"AD",PSIVX),0),U,2),COD=ON55 D DDRUG 122 F PSIVX=0:0 S PSIVX=$O(DRGOC(ON,"SOL",PSIVX)) Q:'PSIVX S DDRUG=$P(^PS(52.7,+DRGOC(ON,"SOL",PSIVX),0),U,2),COD=ON D DDRUG 123 Q 124 DDRUG ;*** Set PSJ(DDRUG NAME) arrays. 125 Q:'DDRUG S DDRUG0=$G(^PSDRUG(+DDRUG,0)),DDRUGND=$G(^PSDRUG(+DDRUG,"ND")) 126 S PSJINX=+$G(PSJINX)+1 ;* ^PSOORDRG calls this entry point. 127 I $D(DDRUG)=11,DDRUG[";" D Q ; if called from ^PSOORDRG 128 .N IPOROP S IPOROP=$P(DDRUG,";",2) 129 .S IPOROP=$S(IPOROP="PSO":";O",IPOROP="PSH":"N;O",1:";I") 130 .S ^TMP($J,"ORDERS",PSJINX)=$P(DDRUG0,U,2)_U_$P(DDRUGND,U)_"A"_$P(DDRUGND,U,3)_U_$P(DDRUG0,U)_U_$S($G(DDRUG(DDRUG)):DDRUG(DDRUG),1:$G(PSJORIEN))_U_$G(COD)_IPOROP 131 S ^TMP($J,"ORDERS",PSJINX)=$P(DDRUG0,U,2)_U_$P(DDRUGND,U)_"A"_$P(DDRUGND,U,3)_U_$P(DDRUG0,U)_U_$G(PSJORIEN)_U_$G(COD)_";I" 132 Q 133 ; 134 PRCHK(PSJ) ; Check if authorized to write med orders. 135 N %,X 136 D NOW^%DTC S X=$G(^VA(200,PSJ,"PS")) I $S('X:1,'$P(%,"^",4):0,1:$P(X,"^",4)'>%) Q 0 137 Q PSJ 138 ; 139 ENNG(PSJDPT,PSJNUM) ; returns 1 if order marked "Not To Be Given" 140 ; 0 if not marked 141 I '$D(^PS(55,PSJDPT,5,+PSJNUM,0)) Q 0 142 I $P($G(^PS(55,PSJDPT,5,+PSJNUM,0)),"^",22)=1 Q 1 143 Q 0
Note:
See TracChangeset
for help on using the changeset viewer.
