- PSJORUT2 ;BIR/MLM-MISC. PROCEDURE CALLS FOR OE/RR 3.0 (CONT.) ;03 Aug 98 / 8:42 AM
- ;;5.0; INPATIENT MEDICATIONS ;**14,29,50,56,58,107,152,134**;16 DEC 97;Build 124
- ;
- ; Reference to ^PS(55 is supported by DBIA 2191
- ; Reference to ^PS(50.605 is supported by DBIA 2138,696.
- ; References to ^PS(52.6 supported by DBIA 1231
- ; Reference to ^PS(52.7 supported by DBIA 2173.
- ; Reference to ^PSDRUG( is supported by DBIA 2192
- ; Reference to ^PSNDF( is supported by DBIA 2195
- ; Reference to ^PSRX( is supported by DBIA 824
- ; Reference to ^PSNAPIS is supported by DBIA 2531
- ;
- ENVAC(PN) ; Find VA CLASS of VA Product Name
- ;Input: PN - See above
- ;Output: VA Drug Class^Classification
- ;
- ; NEW NDF CALL
- 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
- ;
- N GDP,PNP S GDP=$P(PN,"."),PNP=$P(PN,".",2)
- 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)
- Q $S('X:0,PSJC="":0,1:X_U_PSJC)
- ;
- ENVAGN(PN) ; Return VA Generic Name for specified VA Product Name.
- ;Input: PN - VA Product Name IEN
- ;Output: VA Generic Name IEN^VA Generic Name
- ;
- ; NEW NDF CALL
- 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)
- ;
- N GDP,PNP S GDP=+$P(PN,"."),PNP=+$P(PN,".",2)
- S X=$P($G(^PSNDF(GDP,0)),U)
- Q $S('GDP:0,X="":0,1:GDP_U_X)
- ENVOL(PN,ARRAY) ;
- I (PN'["A")&(PN'["B") S ARRAY="0" Q
- 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",X(14)="MMOL"
- I PN["A" N ADD S (ADD,X,XX)=0 F S ADD=$O(^PS(52.6,"AOI",+PN,ADD)) Q:ADD="" D
- .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
- I PN["B" N SOL S SOL=0,XX=0 F S SOL=$O(^PS(52.7,"AOI",+PN,SOL)) Q:SOL="" D
- .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)
- S ARRAY=XX>0
- Q
- ;
- ENVOL2(PN,ARRAY) ;Only for Med Button IV orders.
- I (PN'["A")&(PN'["B") S ARRAY="0" Q
- 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",X(14)="MMOL"
- I PN["A" N ADD S (ADD,X,XX)=0 F S ADD=$O(^PS(52.6,"AOI",+PN,ADD)) Q:ADD="" D
- .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
- I PN["B" N SOL S SOL=0,XX=0 F S SOL=$O(^PS(52.7,"AOI",+PN,SOL)) Q:SOL="" D
- .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)
- S ARRAY=XX>0
- Q
- ;
- ;
- SENVOL(PN,PSJ) ;Return array listing volume (base only) and volume units for the specified additive or solution.
- ;Input: PN - IEN_B (Base) or A (Additive)
- ;Output: ARRAY(IEN,A:additive or B:Base)=volume^volume units
- ; If no volume or units found PSJ=0; If found PSJ=1.
- ;
- N X S PSJ=1
- 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"
- I PN'["A",PN'["B" S PSJ=0 Q
- S PSJ=PSJ+1
- I PN["A" S PSJ(+PN,"A")=U_X(+$P($G(^PS(52.6,+PN,0)),U,3)) Q
- I PN["B" S PSJ(+PN,"B")=+$P($G(^PS(52.7,+PN,0)),U,3)_U_X(1) Q
- Q
- ;
- ENREF(PRX) ; Return number of refills remaining.
- ;Input: PRX - Internal prescription number from File #52.
- ;Output: Number of refills remaining.
- ;
- N X,COUNT,CNT S PRX=$P(PRX,"^"),COUNT=0,X=$P(^PSRX(PRX,0),"^",9)
- D:$O(^PSRX(PRX,1,0))
- .F CNT=0:0 S CNT=$O(^PSRX(PRX,1,CNT)) Q:'CNT S COUNT=COUNT+1
- S:$G(COUNT) X=X-COUNT
- Q X
- ;
- ENCHK(DFN,PSJINX) ; Return dispense drug check array.
- ;Input: DFN - Patient internal entry number
- ; PSJINX - Index number so duplicate drugs will be returned.
- ; PSGOCHK - Check should include dispense drugs in 53.45
- ; PSIVOCHK - Check should include entries in DRG array
- ;Output: ^TMP($J,"ORDERS",PSJINX)=DRUG CLASS^NATIONAL DRUG FILE ENTRY
- ; _"A"_PSNDFA PRODUCT NAME ENTRY_DISPENSE DRUG NAME^OE/RR #
- ; _ORDER NUMBER(P/I/V)_";I"
- ;
- NEW BDT,DDRUG,DDRUG0,DDRUGND,EDT,F,ON,ON1,PST,WBDT,X,PSJORIEN
- D NOW^%DTC S (BDT,WBDT)=%,EDT=9999999
- 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
- 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
- . I $O(^PS(53.1,+ON,"AD",0))!$O(^PS(53.1,+ON,"SOL",0)) D PIV Q
- . D UD
- 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
- I '$G(PSIVOCON) D NEWIV ; Don't do this when Finishing orders (FN)
- Q
- UD ;*** Get the dispense drugs for the Unit Dose orders.
- S PSJORIEN=$P(@(F_ON_",0)"),U,21),DDRUG=0
- I F="^PS(53.1,",($P(@(F_ON_",0)"),U,4)="I") D Q
- . NEW PSJPD S COD=ON_"P"
- . 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
- 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
- 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
- I '$O(@(F_ON_",1,"_0_")")) N OI S OI=+$G(@(F_ON_",.2)")) I OI D
- .S DDRUG="" F S DDRUG=$O(^PSDRUG("ASP",OI,DDRUG)) Q:'DDRUG D
- ..I ($P(DDRUG,U,3)=""!($P(DDRUG,U,3)>BDT)) S COD=ON_$S(F["^PS(53.1":"P",1:"U") D DDRUG
- Q
- PIV ;*** Get the dispense drugs for the Pending IV orders.
- S X=^PS(53.1,+ON,0),PSJORIEN=$P(X,U,21) Q:$P(X,U,27)="R"
- 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
- 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
- Q
- IV ;*** Get the dispense drugs for the IV orders.
- NEW X S X=^PS(55,DFN,"IV",ON,0),PSJORIEN=$P(X,U,21) Q:$P(X,U,17)="R"
- 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
- 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
- Q
- NEWIV ;*** Get the dispense drugs for the newly entered IV order.
- NEW PSIVX,ON
- S ON=$O(DRGOC(0)),PSJORIEN="" Q:'+ON
- 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
- 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
- Q
- DDRUG ;*** Set PSJ(DDRUG NAME) arrays.
- Q:'DDRUG S DDRUG0=$G(^PSDRUG(+DDRUG,0)),DDRUGND=$G(^PSDRUG(+DDRUG,"ND"))
- S PSJINX=+$G(PSJINX)+1 ;* ^PSOORDRG calls this entry point.
- I $D(DDRUG)=11,DDRUG[";" D Q ; if called from ^PSOORDRG
- .N IPOROP S IPOROP=$P(DDRUG,";",2)
- .S IPOROP=$S(IPOROP="PSO":";O",IPOROP="PSH":"N;O",1:";I")
- .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
- 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"
- Q
- ;
- PRCHK(PSJ) ; Check if authorized to write med orders.
- N %,X
- D NOW^%DTC S X=$G(^VA(200,PSJ,"PS")) I $S('X:1,'$P(%,"^",4):0,1:$P(X,"^",4)'>%) Q 0
- Q PSJ
- ;
- ENNG(PSJDPT,PSJNUM) ; returns 1 if order marked "Not To Be Given"
- ; 0 if not marked
- I '$D(^PS(55,PSJDPT,5,+PSJNUM,0)) Q 0
- I $P($G(^PS(55,PSJDPT,5,+PSJNUM,0)),"^",22)=1 Q 1
- Q 0
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJORUT2 8044 printed Dec 13, 2024@02:08:28 Page 2
- PSJORUT2 ;BIR/MLM-MISC. PROCEDURE CALLS FOR OE/RR 3.0 (CONT.) ;03 Aug 98 / 8:42 AM
- +1 ;;5.0; INPATIENT MEDICATIONS ;**14,29,50,56,58,107,152,134**;16 DEC 97;Build 124
- +2 ;
- +3 ; Reference to ^PS(55 is supported by DBIA 2191
- +4 ; Reference to ^PS(50.605 is supported by DBIA 2138,696.
- +5 ; References to ^PS(52.6 supported by DBIA 1231
- +6 ; Reference to ^PS(52.7 supported by DBIA 2173.
- +7 ; Reference to ^PSDRUG( is supported by DBIA 2192
- +8 ; Reference to ^PSNDF( is supported by DBIA 2195
- +9 ; Reference to ^PSRX( is supported by DBIA 824
- +10 ; Reference to ^PSNAPIS is supported by DBIA 2531
- +11 ;
- ENVAC(PN) ; Find VA CLASS of VA Product Name
- +1 ;Input: PN - See above
- +2 ;Output: VA Drug Class^Classification
- +3 ;
- +4 ; NEW NDF CALL
- +5 NEW X
- SET X="PSNAPIS"
- XECUTE ^%ZOSF("TEST")
- IF $TEST
- NEW PSJC,X1,X2
- SET X1=+$PIECE(PN,".")
- SET X2=+$PIECE(PN,".",2)
- SET PSJC=$$DCLASS^PSNAPIS(X1,X2)
- QUIT PSJC
- +6 ;
- +7 NEW GDP,PNP
- SET GDP=$PIECE(PN,".")
- SET PNP=$PIECE(PN,".",2)
- +8 SET X=+$PIECE($GET(^PSNDF(+GDP,5,+PNP,0)),U,2)
- SET X=+$PIECE($GET(^PSNDF(GDP,2,X,0)),U,3)
- SET PSJC=$PIECE($GET(^PS(50.605,X,0)),U,2)
- +9 QUIT $SELECT('X:0,PSJC="":0,1:X_U_PSJC)
- +10 ;
- ENVAGN(PN) ; Return VA Generic Name for specified VA Product Name.
- +1 ;Input: PN - VA Product Name IEN
- +2 ;Output: VA Generic Name IEN^VA Generic Name
- +3 ;
- +4 ; NEW NDF CALL
- +5 NEW X
- SET X="PSNAPIS"
- XECUTE ^%ZOSF("TEST")
- IF $TEST
- NEW GDP,X1,X2
- SET X1=+$PIECE(PN,".")
- SET X2=+$PIECE(PN,".",2)
- SET GDP=$$VAGN^PSNAPIS(X1)
- QUIT $SELECT(GDP=0:0,1:X1_U_GDP)
- +6 ;
- +7 NEW GDP,PNP
- SET GDP=+$PIECE(PN,".")
- SET PNP=+$PIECE(PN,".",2)
- +8 SET X=$PIECE($GET(^PSNDF(GDP,0)),U)
- +9 QUIT $SELECT('GDP:0,X="":0,1:GDP_U_X)
- ENVOL(PN,ARRAY) ;
- +1 IF (PN'["A")&(PN'["B")
- SET ARRAY="0"
- QUIT
- +2 NEW X,XX,F,INACT,IVFL
- +3 SET X(1)="ML"
- SET X(2)="LITER"
- SET X(3)="MCG"
- SET X(4)="MG"
- SET X(5)="GM"
- SET X(6)="UNITS"
- SET X(7)="IU"
- SET X(8)="MEQ"
- SET X(9)="MM"
- SET X(10)="MU"
- SET X(11)="THOUU"
- SET X(12)="MG-PE"
- SET X(13)="NANOGRAM"
- SET X(14)="MMOL"
- +4 IF PN["A"
- NEW ADD
- SET (ADD,X,XX)=0
- FOR
- SET ADD=$ORDER(^PS(52.6,"AOI",+PN,ADD))
- if ADD=""
- QUIT
- Begin DoDot:1
- +5 SET INACT=$GET(^PS(52.6,ADD,"I"))
- IF INACT']""!(INACT>DT)
- SET IVFL=$PIECE($GET(^(0)),"^",13)
- if 'IVFL
- QUIT
- SET XX=XX+1
- SET ARRAY(ADD)="^"_X($PIECE($GET(^PS(52.6,ADD,0)),U,3))
- QUIT
- End DoDot:1
- +6 IF PN["B"
- NEW SOL
- SET SOL=0
- SET XX=0
- FOR
- SET SOL=$ORDER(^PS(52.7,"AOI",+PN,SOL))
- if SOL=""
- QUIT
- Begin DoDot:1
- +7 SET INACT=$GET(^PS(52.7,SOL,"I"))
- IF INACT']""!(INACT>DT)
- SET IVFL=$PIECE($GET(^(0)),"^",13)
- if 'IVFL
- QUIT
- SET XX=XX+1
- SET ARRAY(SOL)=$PIECE($GET(^PS(52.7,SOL,0)),"^",3)
- End DoDot:1
- +8 SET ARRAY=XX>0
- +9 QUIT
- +10 ;
- ENVOL2(PN,ARRAY) ;Only for Med Button IV orders.
- +1 IF (PN'["A")&(PN'["B")
- SET ARRAY="0"
- QUIT
- +2 NEW X,XX,F,INACT
- +3 SET X(1)="ML"
- SET X(2)="LITER"
- SET X(3)="MCG"
- SET X(4)="MG"
- SET X(5)="GM"
- SET X(6)="UNITS"
- SET X(7)="IU"
- SET X(8)="MEQ"
- SET X(9)="MM"
- SET X(10)="MU"
- SET X(11)="THOUU"
- SET X(12)="MG-PE"
- SET X(13)="NANOGRAM"
- SET X(14)="MMOL"
- +4 IF PN["A"
- NEW ADD
- SET (ADD,X,XX)=0
- FOR
- SET ADD=$ORDER(^PS(52.6,"AOI",+PN,ADD))
- if ADD=""
- QUIT
- Begin DoDot:1
- +5 SET INACT=$GET(^PS(52.6,ADD,"I"))
- IF INACT']""!(INACT>DT)
- SET XX=XX+1
- SET ARRAY(ADD)="^"_X($PIECE($GET(^PS(52.6,ADD,0)),U,3))
- QUIT
- End DoDot:1
- +6 IF PN["B"
- NEW SOL
- SET SOL=0
- SET XX=0
- FOR
- SET SOL=$ORDER(^PS(52.7,"AOI",+PN,SOL))
- if SOL=""
- QUIT
- Begin DoDot:1
- +7 SET INACT=$GET(^PS(52.7,SOL,"I"))
- IF INACT']""!(INACT>DT)
- SET XX=XX+1
- SET ARRAY(SOL)=$PIECE($GET(^PS(52.7,SOL,0)),"^",3)
- End DoDot:1
- +8 SET ARRAY=XX>0
- +9 QUIT
- +10 ;
- +11 ;
- SENVOL(PN,PSJ) ;Return array listing volume (base only) and volume units for the specified additive or solution.
- +1 ;Input: PN - IEN_B (Base) or A (Additive)
- +2 ;Output: ARRAY(IEN,A:additive or B:Base)=volume^volume units
- +3 ; If no volume or units found PSJ=0; If found PSJ=1.
- +4 ;
- +5 NEW X
- SET PSJ=1
- +6 SET X(1)="ML"
- SET X(2)="LITER"
- SET X(3)="MCG"
- SET X(4)="MG"
- SET X(5)="GM"
- SET X(6)="UNITS"
- SET X(7)="IU"
- SET X(8)="MEQ"
- SET X(9)="MM"
- SET X(10)="MU"
- SET X(11)="THOUU"
- SET X(12)="MG-PE"
- SET X(13)="NANOGRAM"
- SET X(14)="MMOL"
- +7 IF PN'["A"
- IF PN'["B"
- SET PSJ=0
- QUIT
- +8 SET PSJ=PSJ+1
- +9 IF PN["A"
- SET PSJ(+PN,"A")=U_X(+$PIECE($GET(^PS(52.6,+PN,0)),U,3))
- QUIT
- +10 IF PN["B"
- SET PSJ(+PN,"B")=+$PIECE($GET(^PS(52.7,+PN,0)),U,3)_U_X(1)
- QUIT
- +11 QUIT
- +12 ;
- ENREF(PRX) ; Return number of refills remaining.
- +1 ;Input: PRX - Internal prescription number from File #52.
- +2 ;Output: Number of refills remaining.
- +3 ;
- +4 NEW X,COUNT,CNT
- SET PRX=$PIECE(PRX,"^")
- SET COUNT=0
- SET X=$PIECE(^PSRX(PRX,0),"^",9)
- +5 if $ORDER(^PSRX(PRX,1,0))
- Begin DoDot:1
- +6 FOR CNT=0:0
- SET CNT=$ORDER(^PSRX(PRX,1,CNT))
- if 'CNT
- QUIT
- SET COUNT=COUNT+1
- End DoDot:1
- +7 if $GET(COUNT)
- SET X=X-COUNT
- +8 QUIT X
- +9 ;
- ENCHK(DFN,PSJINX) ; Return dispense drug check array.
- +1 ;Input: DFN - Patient internal entry number
- +2 ; PSJINX - Index number so duplicate drugs will be returned.
- +3 ; PSGOCHK - Check should include dispense drugs in 53.45
- +4 ; PSIVOCHK - Check should include entries in DRG array
- +5 ;Output: ^TMP($J,"ORDERS",PSJINX)=DRUG CLASS^NATIONAL DRUG FILE ENTRY
- +6 ; _"A"_PSNDFA PRODUCT NAME ENTRY_DISPENSE DRUG NAME^OE/RR #
- +7 ; _ORDER NUMBER(P/I/V)_";I"
- +8 ;
- +9 NEW BDT,DDRUG,DDRUG0,DDRUGND,EDT,F,ON,ON1,PST,WBDT,X,PSJORIEN
- +10 DO NOW^%DTC
- SET (BDT,WBDT)=%
- SET EDT=9999999
- +11 SET F="^PS(55,DFN,5,"
- FOR
- SET WBDT=$ORDER(^PS(55,DFN,5,"AUS",WBDT))
- if 'WBDT
- QUIT
- FOR ON=0:0
- SET ON=$ORDER(^PS(55,DFN,5,"AUS",WBDT,ON))
- if 'ON
- QUIT
- DO UD
- +12 SET F="^PS(53.1,"
- FOR PST="P","N"
- FOR ON=0:0
- SET ON=$ORDER(^PS(53.1,"AS",PST,DFN,ON))
- if 'ON
- QUIT
- Begin DoDot:1
- +13 IF $ORDER(^PS(53.1,+ON,"AD",0))!$ORDER(^PS(53.1,+ON,"SOL",0))
- DO PIV
- QUIT
- +14 DO UD
- End DoDot:1
- +15 SET WBDT=BDT
- FOR
- SET WBDT=$ORDER(^PS(55,DFN,"IV","AIS",WBDT))
- if 'WBDT
- QUIT
- FOR ON=0:0
- SET ON=$ORDER(^PS(55,DFN,"IV","AIS",WBDT,ON))
- if 'ON
- QUIT
- DO IV
- +16 ; Don't do this when Finishing orders (FN)
- IF '$GET(PSIVOCON)
- DO NEWIV
- +17 QUIT
- UD ;*** Get the dispense drugs for the Unit Dose orders.
- +1 SET PSJORIEN=$PIECE(@(F_ON_",0)"),U,21)
- SET DDRUG=0
- +2 IF F="^PS(53.1,"
- IF ($PIECE(@(F_ON_",0)"),U,4)="I")
- Begin DoDot:1
- +3 NEW PSJPD
- SET COD=ON_"P"
- +4 SET PSJPD=+$GET(^PS(53.1,ON,.2))
- if $DATA(^PS(52.6,"AOI",PSJPD))
- DO ENDDIV^PSJORUTL(PSJPD,"A","",.DDRUG)
- SET DDRUG=+DDRUG
- if DDRUG
- DO DDRUG
- End DoDot:1
- QUIT
- +5 SET ON1=0
- FOR
- SET ON1=$ORDER(@(F_ON_",1,"_ON1_")"))
- if 'ON1
- QUIT
- SET DDRUG=@(F_ON_",1,"_ON1_",0)")
- IF $PIECE(DDRUG,U,3)=""!($PIECE(DDRUG,U,3)>BDT)
- SET COD=ON_$SELECT(F["^PS(53.1":"P",1:"U")
- DO DDRUG
- +6 IF $DATA(PSGOCHK)
- FOR ON1=0:0
- SET ON1=$ORDER(^PS(53.45,+PSJSYSP,1,ON1))
- if 'ON1
- QUIT
- SET DDRUG=$GET(^PS(53.45,+PSJSYSP,1,ON1,0))
- IF $PIECE(DDRUG,U,3)=""!@($PIECE(DDRUG,U,3)>BDT)
- SET (COD,PSJORIEN)=""
- DO DDRUG
- +7 IF '$ORDER(@(F_ON_",1,"_0_")"))
- NEW OI
- SET OI=+$GET(@(F_ON_",.2)"))
- IF OI
- Begin DoDot:1
- +8 SET DDRUG=""
- FOR
- SET DDRUG=$ORDER(^PSDRUG("ASP",OI,DDRUG))
- if 'DDRUG
- QUIT
- Begin DoDot:2
- +9 IF ($PIECE(DDRUG,U,3)=""!($PIECE(DDRUG,U,3)>BDT))
- SET COD=ON_$SELECT(F["^PS(53.1":"P",1:"U")
- DO DDRUG
- End DoDot:2
- End DoDot:1
- +10 QUIT
- PIV ;*** Get the dispense drugs for the Pending IV orders.
- +1 SET X=^PS(53.1,+ON,0)
- SET PSJORIEN=$PIECE(X,U,21)
- if $PIECE(X,U,27)="R"
- QUIT
- +2 SET ON1=0
- FOR
- SET ON1=$ORDER(^PS(53.1,+ON,"AD",ON1))
- if 'ON1
- QUIT
- SET X=+^PS(53.1,+ON,"AD",ON1,0)
- SET DDRUG=$PIECE($GET(^PS(52.6,X,0)),U,2)
- SET COD=+ON_"P"
- DO DDRUG
- +3 SET ON1=0
- FOR
- SET ON1=$ORDER(^PS(53.1,+ON,"SOL",ON1))
- if 'ON1
- QUIT
- SET X=+^PS(53.1,+ON,"SOL",ON1,0)
- SET DDRUG=$PIECE($GET(^PS(52.7,X,0)),U,2)
- SET COD=+ON_"P"
- DO DDRUG
- +4 QUIT
- IV ;*** Get the dispense drugs for the IV orders.
- +1 NEW X
- SET X=^PS(55,DFN,"IV",ON,0)
- SET PSJORIEN=$PIECE(X,U,21)
- if $PIECE(X,U,17)="R"
- QUIT
- +2 SET ON1=0
- FOR
- SET ON1=$ORDER(^PS(55,DFN,"IV",ON,"AD",ON1))
- if 'ON1
- QUIT
- SET X=+^PS(55,DFN,"IV",ON,"AD",ON1,0)
- SET DDRUG=$PIECE($GET(^PS(52.6,X,0)),U,2)
- SET COD=ON_"V"
- DO DDRUG
- +3 SET ON1=0
- FOR
- SET ON1=$ORDER(^PS(55,DFN,"IV",ON,"SOL",ON1))
- if 'ON1
- QUIT
- SET X=+^PS(55,DFN,"IV",ON,"SOL",ON1,0)
- SET DDRUG=$PIECE($GET(^PS(52.7,X,0)),U,2)
- SET COD=ON_"V"
- DO DDRUG
- +4 QUIT
- NEWIV ;*** Get the dispense drugs for the newly entered IV order.
- +1 NEW PSIVX,ON
- +2 SET ON=$ORDER(DRGOC(0))
- SET PSJORIEN=""
- if '+ON
- QUIT
- +3 FOR PSIVX=0:0
- SET PSIVX=$ORDER(DRGOC(ON,"AD",PSIVX))
- if 'PSIVX
- QUIT
- SET DDRUG=$PIECE(^PS(52.6,+DRGOC(ON,"AD",PSIVX),0),U,2)
- SET COD=ON55
- DO DDRUG
- +4 FOR PSIVX=0:0
- SET PSIVX=$ORDER(DRGOC(ON,"SOL",PSIVX))
- if 'PSIVX
- QUIT
- SET DDRUG=$PIECE(^PS(52.7,+DRGOC(ON,"SOL",PSIVX),0),U,2)
- SET COD=ON
- DO DDRUG
- +5 QUIT
- DDRUG ;*** Set PSJ(DDRUG NAME) arrays.
- +1 if 'DDRUG
- QUIT
- SET DDRUG0=$GET(^PSDRUG(+DDRUG,0))
- SET DDRUGND=$GET(^PSDRUG(+DDRUG,"ND"))
- +2 ;* ^PSOORDRG calls this entry point.
- SET PSJINX=+$GET(PSJINX)+1
- +3 ; if called from ^PSOORDRG
- IF $DATA(DDRUG)=11
- IF DDRUG[";"
- Begin DoDot:1
- +4 NEW IPOROP
- SET IPOROP=$PIECE(DDRUG,";",2)
- +5 SET IPOROP=$SELECT(IPOROP="PSO":";O",IPOROP="PSH":"N;O",1:";I")
- +6 SET ^TMP($JOB,"ORDERS",PSJINX)=$PIECE(DDRUG0,U,2)_U_$PIECE(DDRUGND,U)_"A"_$PIECE(DDRUGND,U,3)_U_$PIECE(DDRUG0,U)_U_$SELECT($GET(DDRUG(DDRUG)):DDRUG(DDRUG),1:$GET(PSJORIEN))_U_$GET(COD)_IPOROP
- End DoDot:1
- QUIT
- +7 SET ^TMP($JOB,"ORDERS",PSJINX)=$PIECE(DDRUG0,U,2)_U_$PIECE(DDRUGND,U)_"A"_$PIECE(DDRUGND,U,3)_U_$PIECE(DDRUG0,U)_U_$GET(PSJORIEN)_U_$GET(COD)_";I"
- +8 QUIT
- +9 ;
- PRCHK(PSJ) ; Check if authorized to write med orders.
- +1 NEW %,X
- +2 DO NOW^%DTC
- SET X=$GET(^VA(200,PSJ,"PS"))
- IF $SELECT('X:1,'$PIECE(%,"^",4):0,1:$PIECE(X,"^",4)'>%)
- QUIT 0
- +3 QUIT PSJ
- +4 ;
- ENNG(PSJDPT,PSJNUM) ; returns 1 if order marked "Not To Be Given"
- +1 ; 0 if not marked
- +2 IF '$DATA(^PS(55,PSJDPT,5,+PSJNUM,0))
- QUIT 0
- +3 IF $PIECE($GET(^PS(55,PSJDPT,5,+PSJNUM,0)),"^",22)=1
- QUIT 1
- +4 QUIT 0