PSIVEDRG ;BIR/MLM - ENTER/EDIT DRUGS FOR IV ORDER ;16 Mar 99 / 2:14 PM
;;5.0;INPATIENT MEDICATIONS ;**21,33,50,65,74,84,128,147,181,263,281,313,355**;16 DEC 97;Build 4
;
; References to ^PS(52.6 supported by DBIA# 1231.
; References to ^PS(52.7 supported by DBIA# 2173.
; Reference to EN^PSOORDRG supported by DBIA# 2190.
; Reference to ^TMP("PSODAOC",$J supported by DBIA #6071.
;
DRG ; Edit Additive/Solution data
N DRGOC K PSGORQF ;If PSGORQF=1 abort order after order check.
K PSIVOLD S DRG(2)="" I $D(DRG(DRGT)) S DRGI=+$O(DRG(DRGT,0)) I DRGI S PSIVOLD=1 D SETDRG
DRG1 ;
Q:$G(PSGORQF)
I $G(X)="?" K DUOUT
D FULL^VALM1
W !,"Select ",DRGTN,": "
I DRGT=$G(PSIVOI),($G(PSIVOI("DILIST",0))>1) D GTADSOL Q
W:DRG(2)]"" DRG(2),"//" R X:DTIME S:'$T X="^" S:X=U DONE=1 I X["^"!(X=""&(DRG(2)="")) D CHKSCMNT Q
DRG1A I X="" W !,DRGTN,": ",DRG(2),"//" R X:DTIME S:'$T X="^" D:X="^" CHKSCMNT Q:X="^" I X="" S Y=1 D DRG3 G:DRGT="AD"!($G(P(4))="H") DRG1 Q
I X="@",DRG(2)]"" D DEL G:%'=1 DRG1A K DRG(DRGT,DRGI),^TMP("PSODAOC",$J) S DRGI=+$O(DRG(DRGT,0)) S:'DRGI DRG(DRGT,0)=0 D SETDRG G DRG1
I X["???",($E(P("OT"))="M"),(PSIVAC["C") D ORFLDS^PSIVEDT1 G DRG1
I X'["?" S %=0 D:$D(DRG(DRGT)) CHK G:%=1 DRG1A D DRG2 Q:$G(Y)>0&($G(P(4))'="H"&(DRGT="SOL")) G DRG1
I $D(DRG(DRGT)) W !,"This order includes the following ",DRGTN,"S:",! D
. F Y=0:0 S Y=$O(DRG(DRGT,Y)) Q:'Y D
. . W !,$P(DRG(DRGT,Y),U,2)
. . W:DRGT="AD" ?40,"Additive Strength: ",$S($$GET1^DIQ(52.6,+$G(DRG(DRGT,Y)),19):$$GET1^DIQ(52.6,+$G(DRG(DRGT,Y)),19)_" "_$$GET1^DIQ(52.6,+$G(DRG(DRGT,Y)),2),1:"N/A")
W !!,"YOU MAY ENTER A NEW ",DRGTN,", IF YOU WISH",! D GTSCRN(X) S DIC(0)="EQM" D ^DIC K DIC G DRG1
Q
;
SETDRG ; Put Drug data into DRG(x).
F X=1:1:6 S DRG(X)=$P(DRG(DRGT,DRGI),U,X)
S X="" I DRG(2)="",DRG(1) S DRG(2)="*** Undefined ***"
Q
DRG2 ;
D GTSCRN(X) N PSIVX S PSIVX=X,DIC(0)="EQMZ" D ^DIC K DIC Q:Y<0
S PSJIVIEN=+Y
N PSJNF D NFIV^PSJDIN($S(DRGT="AD":52.6,1:52.7),+PSJIVIEN,.PSJNF)
W PSJNF("NF")
S PSIVNEW=1,DRGTMP=+Y_U_$P(Y(0),U)_U_$S(DRGT="SOL":$P(Y(0),U,3),1:"")_U_U_$P(Y(0),U,13)_U_$P(Y(0),U,11)
I '$D(ON55) N ON55 S ON55=ON
D ORDERCHK(DFN,ON55,1) I $G(PSGORQF) S X=U,DONE=1 Q
D DINIV^PSJDIN($S(DRGT="AD":52.6,1:52.7),+DRGTMP)
S (DRG(DRGT,0),DRGI)=$G(DRG(DRGT,0))+1,DRG(DRGT,DRGI)=DRGTMP K PSIVOLD
I (PSIVAC="PN"!(PSIVAC="CF")),(DRGT="AD"),$D(^PS(52.6,"C",PSIVX,+DRGTMP)) D ^PSIVQUI Q:$G(PSIVSTR)="QUICK CODE"!$G(PSGORQF)
DRG3 ;
D:DRG(2)]"" DINIV^PSJDIN(FIL,+DRG(1))
D SETDRG
I DRGT="AD" S X=$P($G(^PS(FIL,+DRG(1),0)),U,3) W !!,"(The units of strength for this additive are in ",$$ENU^PSIVUTL(DRG(1)),")"
AMT ;
I DRGT="SOL",'$G(PSIVOLD),($G(P(4))_$G(P(23))'["S") G DRG4
1 ; Strength/Volume
W !,$S(DRGT="AD":"Strength: ",1:"Volume: ") W:+DRG(3) DRG(3),"//" R X:DTIME S:'$T X="^" Q:X="^" G:X=""&DRG(3) 2 I X="" W $C(7),$S(DRGT="AD":"Strength",1:"Volume")," is REQUIRED!" G 1
D:$D(X) IT G:'$D(X)!($G(X)["?") AMT S DRG(3)=X I X="" D FIELD^DID($S(DRGT="AD":53.157,1:53.158),1,"","XECUTABLE HELP","PSJEX") X PSJEX("XECUTABLE HELP") K PSJEX G AMT
2 ;
I DRGT="AD",$G(P("DTYP"))>1,P(4)'="S",P(23)'="S" K DIR S DIR(0)="53.157,2" S:DRG(4)]"" DIR("B")=DRG(4) D ^DIR Q:$D(DTOUT)!$D(DUOUT) S:X="@" DRG(4)="" S:Y DRG(4)=Y
DRG4 ;
F X=1:1:6 S $P(DRG(DRGT,DRGI),U,X)=DRG(X)
S DRG(2)=""
Q
;
CHKSCMNT ;
I $$SEECMENT() W !!,"*** One or more additives has 'See Comments' in the Bottle field.",!," Please correct.",!!
Q
SEECMENT() ;
;Return 1 if DRG array still contain "See Comments"
N PSIVDRGI,PSIVDRG0,PSIVFLG
S PSIVFLG=0
F PSIVDRGI=0:0 S PSIVDRGI=$O(DRG("AD",PSIVDRGI)) Q:'PSIVDRGI Q:PSIVFLG D
. S PSIVDRG0=$G(DRG("AD",PSIVDRGI))
. I $P(PSIVDRG0,U,4)="See Comments" S PSIVFLG=1
Q PSIVFLG
GTSCRN(PSIVX) ;Set DIC("S") if MD OE or matching drug has already been selected.
D:"?"[PSIVX HOLDHDR^PSJOE
S X=PSIVX
K DA,DIC S DIC=FIL,DIC("S")=$$IVDRGSC^PSIVUTL
I $E(PSIVAC)'="P",($P(P("OT"),U)="F") S X(1)=" I $P(X(1),U,13)",DIC("S")=$G(DIC("S"))_$S(DRGT="AD":X(1),$E(PSIVAC)="O":X(1),1:"")
Q
;
IT ; Input Transform for Strength/Volume.
I X?1.N,$L(X)>20 S X="?"
I X["?" W $C(7) S F1=53.15_$S(DRGT="AD":7,1:8),F2=1 D ENHLP^PSIVORC1 Q
I DRGT="AD" K:X'?.6N0.1".".8N!('X) X I $D(X) S:(X<1)&($P(X,".")'=0) X=0_X S X=X_" "_$$ENU^PSIVUTL(DRG(1)) W " ",X Q
I $D(X) K:X=""!(X'?.N0.1".".N)!(X>9999)!(X<.01) X I $D(X) S:(X<1)&($P(X,".")'=0) X=0_X S X=X_" ML" W " ",X
W:'$D(X) $C(7),"??"
Q
;
ORDERCHK(DFN,ON,X) ; Do order check
;* If X is define, include the DRG(X) to the order check
;This module is no longer used as of PSJ*5*181
Q
I X M:$D(DRG) DRGOC(ON)=DRG
N TMPDRG,X,XX,Y,PSIVNEW,PSGDRG,PSGDRGN,PSJDD,PSGP
D SAVEDRG(.TMPDRG,.DRG) ;Store DRG array in TMPDRG array
S PSIVNEW=1,PSGDRGN=$P($G(DRGTMP),U,2)
S (PSJDD,PSGDRG)=$P(^PS(FIL,+DRGTMP,0),U,2),PSGP=DFN
I FIL="52.6" D ENDDC^PSGSICHK(DFN,PSGDRG)
I FIL="52.7" D
. D EN^PSOORDRG(DFN,PSGDRG)
. N INTERVEN,PSJIREQ,PSJRXREQ S Y=1,(PSJIREQ,PSJRXREQ,INTERVEN,X)=""
. S DFN=PSGP K PSJPDRG
. D IVSOL^PSGSICHK
D SAVEDRG(.DRG,.TMPDRG) ;Restore DRG array from TMPDRG array
D ENSTOP^PSIVCAL
Q
SAVEDRG(NEW,OLD) ;Store/restore DRG array.
K NEW
S:$G(OLD) NEW=OLD
F X=0:0 S X=$O(OLD(X)) Q:'X S NEW(X)=OLD(X)
F XX="AD","SOL" D
. I $D(OLD(XX,0))#10=1 S NEW(XX,0)=OLD(XX,0)
. F X=0:0 S X=$O(OLD(XX,X)) Q:'X S NEW(XX,X)=OLD(XX,X)
Q
;
CHK ; Check if drug is already part of order
N DDONE,I,TDRG,TDRGP,J F TDRG=0:0 S TDRG=$O(DRG(DRGT,TDRG)) Q:'TDRG!$G(DDONE) D
.I $$UPPER^VALM1($E($P(DRG(DRGT,+TDRG),U,2),1,$L(X)))=$$UPPER^VALM1(X) W $P($$UPPER^VALM1($P(DRG(DRGT,+TDRG),U,2)),$$UPPER^VALM1(X),2) D ASKCHK Q
.S TDRGP=$P(DRG(DRGT,TDRG),U) F J=0:0 S J=$O(^PS(FIL,TDRGP,3,J)) Q:'J!$G(DDONE) I $$UPPER^VALM1($E($P(^PS(FIL,TDRGP,3,J,0),U),1,$L(X)))=$$UPPER^VALM1(X) D D ASKCHK Q
..W $P($$UPPER^VALM1($P(^PS(FIL,TDRGP,3,J,0),U)),$$UPPER^VALM1(X),2)," ",$P(DRG(DRGT,TDRG),U,2)
Q
;
ASKCHK ; Do you want a drug that was previously selected.
S I=DRG(DRGT,TDRG) W " ",$S($P(I,U,4):" ("_$P(I,U,4)_")",1:""),!,"...OK" S %=1 D YN^DICN
I %=1 S X="",DRGI=TDRG,(DDONE,PSIVOLD)=1 D SETDRG Q
W !,X
Q
;
DEL ;
W !?3,"SURE YOU WANT TO DELETE" S %=0 D YN^DICN S X="" I %'=1 W " <NOTHING DELETED>"
Q
GTADSOL ;Prompt for an ad/sol if there were multiple ad/sol matched to an OI
;PSIVOI array is defined in GTIVDRG^PSIVORC2
N DIR,ND,X,Y
S DIR(0)="LA^1:"_+PSIVOI("DILIST",0)
S DIR("?")="Please select "_$S(PSIVOI="AD":"an Additive or Quick Code",1:"a Solution")_" from the list"
F X=0:0 S X=$O(PSIVOI("DILIST",X)) Q:'X D
. S DIR("A",X)=" "_X_" "_$S($P(PSIVOI("DILIST",X,0),U,4)="QC":" - "_$P(PSIVOI("DILIST",X,0),U,2)_" -",1:$P(PSIVOI("DILIST",X,0),U,2))
. I PSIVOI="SOL" S $E(DIR("A",X),35)=$P(PSIVOI("DILIST",X,0),U,3)
. I $P(PSIVOI("DILIST",X,0),U,4)="QC" D
..I PSIVOI="AD" S $E(DIR("A",X),35)="Quick Code Strength: "_$S($P(PSIVOI("DILIST",X,0),U,5)'="":$P(PSIVOI("DILIST",X,0),U,5),1:"N/A")_" "_" SCHEDULE: "_$S($P(PSIVOI("DILIST",X,0),U,6)'="":$P(PSIVOI("DILIST",X,0),U,6),1:"N/A")
.E D
..I PSIVOI="AD" S $E(DIR("A",X),40)="Additive Strength: "_$S($P(PSIVOI("DILIST",X,0),U,4)'="":$P(PSIVOI("DILIST",X,0),U,4)_" "_$P(PSIVOI("DILIST",X,0),U,3),1:"N/A")
S DIR("A")="Select (1 - "_+PSIVOI("DILIST",0)_"): "
D ^DIR
I +Y D
. N PSIVOIND S PSIVOIND=PSIVOI("DILIST",+Y,0)
. W " "_$P(PSIVOIND,U,2)_$S(PSIVOI="SOL":" "_$P(PSIVOIND,U,3),1:"")
. S ND=$G(^PS($S(PSIVOI="AD":52.6,1:52.7),+PSIVOIND,0))
. S DRG(PSIVOI,0)=1
. S DRG(PSIVOI,1)=+PSIVOIND_U_$P(ND,U)_U_$S(PSIVOI="SOL":$P(ND,U,3),1:"")_U_U_$P(ND,U,13)_U_$P(ND,U,11)
. S DRGI=1 D SETDRG
. I $P(PSIVOI("DILIST",+Y,0),U,4)="QC",DRGT="AD",$D(^PS(52.6,"C",$P(PSIVOI("DILIST",+Y,0),U,2),+PSIVOI("DILIST",+Y,0))) D Q:$G(PSIVSTR)="QUICK CODE"!$G(PSGORQF)
.. S (X,PSIVX)=$P(PSIVOI("DILIST",+Y,0),U,2),(PSJIVIEN,Y)=+PSIVOI("DILIST",+Y,0) D
... N PSJNF D NFIV^PSJDIN(52.6,+PSJIVIEN,.PSJNF) W PSJNF("NF")
... S DRGTMP=DRG(DRGT,1)
... I '$D(ON55) N ON55 S ON55=ON
... D ORDERCHK(DFN,ON55,1) I $G(PSGORQF) S X=U,DONE=1 Q
... D DINIV^PSJDIN(52.6,+DRGTMP)
... D ^PSIVQUI
. I $P(PSIVOI("DILIST",+Y,0),U,4)'="QC" S DRGTMP=DRG(DRGT,1) D ORDERCHK(DFN,ON55,1) I $G(PSGORQF) S X=U,DONE=1 Q
. I PSIVOI="AD" D
.. N FIL S FIL=52.6 D DRG3
K PSIVOI
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVEDRG 8338 printed Oct 16, 2024@18:04:51 Page 2
PSIVEDRG ;BIR/MLM - ENTER/EDIT DRUGS FOR IV ORDER ;16 Mar 99 / 2:14 PM
+1 ;;5.0;INPATIENT MEDICATIONS ;**21,33,50,65,74,84,128,147,181,263,281,313,355**;16 DEC 97;Build 4
+2 ;
+3 ; References to ^PS(52.6 supported by DBIA# 1231.
+4 ; References to ^PS(52.7 supported by DBIA# 2173.
+5 ; Reference to EN^PSOORDRG supported by DBIA# 2190.
+6 ; Reference to ^TMP("PSODAOC",$J supported by DBIA #6071.
+7 ;
DRG ; Edit Additive/Solution data
+1 ;If PSGORQF=1 abort order after order check.
NEW DRGOC
KILL PSGORQF
+2 KILL PSIVOLD
SET DRG(2)=""
IF $DATA(DRG(DRGT))
SET DRGI=+$ORDER(DRG(DRGT,0))
IF DRGI
SET PSIVOLD=1
DO SETDRG
DRG1 ;
+1 if $GET(PSGORQF)
QUIT
+2 IF $GET(X)="?"
KILL DUOUT
+3 DO FULL^VALM1
+4 WRITE !,"Select ",DRGTN,": "
+5 IF DRGT=$GET(PSIVOI)
IF ($GET(PSIVOI("DILIST",0))>1)
DO GTADSOL
QUIT
+6 if DRG(2)]""
WRITE DRG(2),"//"
READ X:DTIME
if '$TEST
SET X="^"
if X=U
SET DONE=1
IF X["^"!(X=""&(DRG(2)=""))
DO CHKSCMNT
QUIT
DRG1A IF X=""
WRITE !,DRGTN,": ",DRG(2),"//"
READ X:DTIME
if '$TEST
SET X="^"
if X="^"
DO CHKSCMNT
if X="^"
QUIT
IF X=""
SET Y=1
DO DRG3
if DRGT="AD"!($GET(P(4))="H")
GOTO DRG1
QUIT
+1 IF X="@"
IF DRG(2)]""
DO DEL
if %'=1
GOTO DRG1A
KILL DRG(DRGT,DRGI),^TMP("PSODAOC",$JOB)
SET DRGI=+$ORDER(DRG(DRGT,0))
if 'DRGI
SET DRG(DRGT,0)=0
DO SETDRG
GOTO DRG1
+2 IF X["???"
IF ($EXTRACT(P("OT"))="M")
IF (PSIVAC["C")
DO ORFLDS^PSIVEDT1
GOTO DRG1
+3 IF X'["?"
SET %=0
if $DATA(DRG(DRGT))
DO CHK
if %=1
GOTO DRG1A
DO DRG2
if $GET(Y)>0&($GET(P(4))'="H"&(DRGT="SOL"))
QUIT
GOTO DRG1
+4 IF $DATA(DRG(DRGT))
WRITE !,"This order includes the following ",DRGTN,"S:",!
Begin DoDot:1
+5 FOR Y=0:0
SET Y=$ORDER(DRG(DRGT,Y))
if 'Y
QUIT
Begin DoDot:2
+6 WRITE !,$PIECE(DRG(DRGT,Y),U,2)
+7 if DRGT="AD"
WRITE ?40,"Additive Strength: ",$SELECT($$GET1^DIQ(52.6,+$GET(DRG(DRGT,Y)),19):$$GET1^DIQ(52.6,+$GET(DRG(DRGT,Y)),19)_" "_$$GET1^DIQ(52.6,+$GET(DRG(DRGT,Y)),2),1:"N/A")
End DoDot:2
End DoDot:1
+8 WRITE !!,"YOU MAY ENTER A NEW ",DRGTN,", IF YOU WISH",!
DO GTSCRN(X)
SET DIC(0)="EQM"
DO ^DIC
KILL DIC
GOTO DRG1
+9 QUIT
+10 ;
SETDRG ; Put Drug data into DRG(x).
+1 FOR X=1:1:6
SET DRG(X)=$PIECE(DRG(DRGT,DRGI),U,X)
+2 SET X=""
IF DRG(2)=""
IF DRG(1)
SET DRG(2)="*** Undefined ***"
+3 QUIT
DRG2 ;
+1 DO GTSCRN(X)
NEW PSIVX
SET PSIVX=X
SET DIC(0)="EQMZ"
DO ^DIC
KILL DIC
if Y<0
QUIT
+2 SET PSJIVIEN=+Y
+3 NEW PSJNF
DO NFIV^PSJDIN($SELECT(DRGT="AD":52.6,1:52.7),+PSJIVIEN,.PSJNF)
+4 WRITE PSJNF("NF")
+5 SET PSIVNEW=1
SET DRGTMP=+Y_U_$PIECE(Y(0),U)_U_$SELECT(DRGT="SOL":$PIECE(Y(0),U,3),1:"")_U_U_$PIECE(Y(0),U,13)_U_$PIECE(Y(0),U,11)
+6 IF '$DATA(ON55)
NEW ON55
SET ON55=ON
+7 DO ORDERCHK(DFN,ON55,1)
IF $GET(PSGORQF)
SET X=U
SET DONE=1
QUIT
+8 DO DINIV^PSJDIN($SELECT(DRGT="AD":52.6,1:52.7),+DRGTMP)
+9 SET (DRG(DRGT,0),DRGI)=$GET(DRG(DRGT,0))+1
SET DRG(DRGT,DRGI)=DRGTMP
KILL PSIVOLD
+10 IF (PSIVAC="PN"!(PSIVAC="CF"))
IF (DRGT="AD")
IF $DATA(^PS(52.6,"C",PSIVX,+DRGTMP))
DO ^PSIVQUI
if $GET(PSIVSTR)="QUICK CODE"!$GET(PSGORQF)
QUIT
DRG3 ;
+1 if DRG(2)]""
DO DINIV^PSJDIN(FIL,+DRG(1))
+2 DO SETDRG
+3 IF DRGT="AD"
SET X=$PIECE($GET(^PS(FIL,+DRG(1),0)),U,3)
WRITE !!,"(The units of strength for this additive are in ",$$ENU^PSIVUTL(DRG(1)),")"
AMT ;
+1 IF DRGT="SOL"
IF '$GET(PSIVOLD)
IF ($GET(P(4))_$GET(P(23))'["S")
GOTO DRG4
1 ; Strength/Volume
+1 WRITE !,$SELECT(DRGT="AD":"Strength: ",1:"Volume: ")
if +DRG(3)
WRITE DRG(3),"//"
READ X:DTIME
if '$TEST
SET X="^"
if X="^"
QUIT
if X=""&DRG(3)
GOTO 2
IF X=""
WRITE $CHAR(7),$SELECT(DRGT="AD":"Strength",1:"Volume")," is REQUIRED!"
GOTO 1
+2 if $DATA(X)
DO IT
if '$DATA(X)!($GET(X)["?")
GOTO AMT
SET DRG(3)=X
IF X=""
DO FIELD^DID($SELECT(DRGT="AD":53.157,1:53.158),1,"","XECUTABLE HELP","PSJEX")
XECUTE PSJEX("XECUTABLE HELP")
KILL PSJEX
GOTO AMT
2 ;
+1 IF DRGT="AD"
IF $GET(P("DTYP"))>1
IF P(4)'="S"
IF P(23)'="S"
KILL DIR
SET DIR(0)="53.157,2"
if DRG(4)]""
SET DIR("B")=DRG(4)
DO ^DIR
if $DATA(DTOUT)!$DATA(DUOUT)
QUIT
if X="@"
SET DRG(4)=""
if Y
SET DRG(4)=Y
DRG4 ;
+1 FOR X=1:1:6
SET $PIECE(DRG(DRGT,DRGI),U,X)=DRG(X)
+2 SET DRG(2)=""
+3 QUIT
+4 ;
CHKSCMNT ;
+1 IF $$SEECMENT()
WRITE !!,"*** One or more additives has 'See Comments' in the Bottle field.",!," Please correct.",!!
+2 QUIT
SEECMENT() ;
+1 ;Return 1 if DRG array still contain "See Comments"
+2 NEW PSIVDRGI,PSIVDRG0,PSIVFLG
+3 SET PSIVFLG=0
+4 FOR PSIVDRGI=0:0
SET PSIVDRGI=$ORDER(DRG("AD",PSIVDRGI))
if 'PSIVDRGI
QUIT
if PSIVFLG
QUIT
Begin DoDot:1
+5 SET PSIVDRG0=$GET(DRG("AD",PSIVDRGI))
+6 IF $PIECE(PSIVDRG0,U,4)="See Comments"
SET PSIVFLG=1
End DoDot:1
+7 QUIT PSIVFLG
GTSCRN(PSIVX) ;Set DIC("S") if MD OE or matching drug has already been selected.
+1 if "?"[PSIVX
DO HOLDHDR^PSJOE
+2 SET X=PSIVX
+3 KILL DA,DIC
SET DIC=FIL
SET DIC("S")=$$IVDRGSC^PSIVUTL
+4 IF $EXTRACT(PSIVAC)'="P"
IF ($PIECE(P("OT"),U)="F")
SET X(1)=" I $P(X(1),U,13)"
SET DIC("S")=$GET(DIC("S"))_$SELECT(DRGT="AD":X(1),$EXTRACT(PSIVAC)="O":X(1),1:"")
+5 QUIT
+6 ;
IT ; Input Transform for Strength/Volume.
+1 IF X?1.N
IF $LENGTH(X)>20
SET X="?"
+2 IF X["?"
WRITE $CHAR(7)
SET F1=53.15_$SELECT(DRGT="AD":7,1:8)
SET F2=1
DO ENHLP^PSIVORC1
QUIT
+3 IF DRGT="AD"
if X'?.6N0.1".".8N!('X)
KILL X
IF $DATA(X)
if (X<1)&($PIECE(X,".")'=0)
SET X=0_X
SET X=X_" "_$$ENU^PSIVUTL(DRG(1))
WRITE " ",X
QUIT
+4 IF $DATA(X)
if X=""!(X'?.N0.1".".N)!(X>9999)!(X<.01)
KILL X
IF $DATA(X)
if (X<1)&($PIECE(X,".")'=0)
SET X=0_X
SET X=X_" ML"
WRITE " ",X
+5 if '$DATA(X)
WRITE $CHAR(7),"??"
+6 QUIT
+7 ;
ORDERCHK(DFN,ON,X) ; Do order check
+1 ;* If X is define, include the DRG(X) to the order check
+2 ;This module is no longer used as of PSJ*5*181
+3 QUIT
+4 IF X
if $DATA(DRG)
MERGE DRGOC(ON)=DRG
+5 NEW TMPDRG,X,XX,Y,PSIVNEW,PSGDRG,PSGDRGN,PSJDD,PSGP
+6 ;Store DRG array in TMPDRG array
DO SAVEDRG(.TMPDRG,.DRG)
+7 SET PSIVNEW=1
SET PSGDRGN=$PIECE($GET(DRGTMP),U,2)
+8 SET (PSJDD,PSGDRG)=$PIECE(^PS(FIL,+DRGTMP,0),U,2)
SET PSGP=DFN
+9 IF FIL="52.6"
DO ENDDC^PSGSICHK(DFN,PSGDRG)
+10 IF FIL="52.7"
Begin DoDot:1
+11 DO EN^PSOORDRG(DFN,PSGDRG)
+12 NEW INTERVEN,PSJIREQ,PSJRXREQ
SET Y=1
SET (PSJIREQ,PSJRXREQ,INTERVEN,X)=""
+13 SET DFN=PSGP
KILL PSJPDRG
+14 DO IVSOL^PSGSICHK
End DoDot:1
+15 ;Restore DRG array from TMPDRG array
DO SAVEDRG(.DRG,.TMPDRG)
+16 DO ENSTOP^PSIVCAL
+17 QUIT
SAVEDRG(NEW,OLD) ;Store/restore DRG array.
+1 KILL NEW
+2 if $GET(OLD)
SET NEW=OLD
+3 FOR X=0:0
SET X=$ORDER(OLD(X))
if 'X
QUIT
SET NEW(X)=OLD(X)
+4 FOR XX="AD","SOL"
Begin DoDot:1
+5 IF $DATA(OLD(XX,0))#10=1
SET NEW(XX,0)=OLD(XX,0)
+6 FOR X=0:0
SET X=$ORDER(OLD(XX,X))
if 'X
QUIT
SET NEW(XX,X)=OLD(XX,X)
End DoDot:1
+7 QUIT
+8 ;
CHK ; Check if drug is already part of order
+1 NEW DDONE,I,TDRG,TDRGP,J
FOR TDRG=0:0
SET TDRG=$ORDER(DRG(DRGT,TDRG))
if 'TDRG!$GET(DDONE)
QUIT
Begin DoDot:1
+2 IF $$UPPER^VALM1($EXTRACT($PIECE(DRG(DRGT,+TDRG),U,2),1,$LENGTH(X)))=$$UPPER^VALM1(X)
WRITE $PIECE($$UPPER^VALM1($PIECE(DRG(DRGT,+TDRG),U,2)),$$UPPER^VALM1(X),2)
DO ASKCHK
QUIT
+3 SET TDRGP=$PIECE(DRG(DRGT,TDRG),U)
FOR J=0:0
SET J=$ORDER(^PS(FIL,TDRGP,3,J))
if 'J!$GET(DDONE)
QUIT
IF $$UPPER^VALM1($EXTRACT($PIECE(^PS(FIL,TDRGP,3,J,0),U),1,$LENGTH(X)))=$$UPPER^VALM1(X)
Begin DoDot:2
+4 WRITE $PIECE($$UPPER^VALM1($PIECE(^PS(FIL,TDRGP,3,J,0),U)),$$UPPER^VALM1(X),2)," ",$PIECE(DRG(DRGT,TDRG),U,2)
End DoDot:2
DO ASKCHK
QUIT
End DoDot:1
+5 QUIT
+6 ;
ASKCHK ; Do you want a drug that was previously selected.
+1 SET I=DRG(DRGT,TDRG)
WRITE " ",$SELECT($PIECE(I,U,4):" ("_$PIECE(I,U,4)_")",1:""),!,"...OK"
SET %=1
DO YN^DICN
+2 IF %=1
SET X=""
SET DRGI=TDRG
SET (DDONE,PSIVOLD)=1
DO SETDRG
QUIT
+3 WRITE !,X
+4 QUIT
+5 ;
DEL ;
+1 WRITE !?3,"SURE YOU WANT TO DELETE"
SET %=0
DO YN^DICN
SET X=""
IF %'=1
WRITE " <NOTHING DELETED>"
+2 QUIT
GTADSOL ;Prompt for an ad/sol if there were multiple ad/sol matched to an OI
+1 ;PSIVOI array is defined in GTIVDRG^PSIVORC2
+2 NEW DIR,ND,X,Y
+3 SET DIR(0)="LA^1:"_+PSIVOI("DILIST",0)
+4 SET DIR("?")="Please select "_$SELECT(PSIVOI="AD":"an Additive or Quick Code",1:"a Solution")_" from the list"
+5 FOR X=0:0
SET X=$ORDER(PSIVOI("DILIST",X))
if 'X
QUIT
Begin DoDot:1
+6 SET DIR("A",X)=" "_X_" "_$SELECT($PIECE(PSIVOI("DILIST",X,0),U,4)="QC":" - "_$PIECE(PSIVOI("DILIST",X,0),U,2)_" -",1:$PIECE(PSIVOI("DILIST",X,0),U,2))
+7 IF PSIVOI="SOL"
SET $EXTRACT(DIR("A",X),35)=$PIECE(PSIVOI("DILIST",X,0),U,3)
+8 IF $PIECE(PSIVOI("DILIST",X,0),U,4)="QC"
Begin DoDot:2
+9 IF PSIVOI="AD"
SET $EXTRACT(DIR("A",X),35)="Quick Code Strength: "_$SELECT($PIECE(PSIVOI("DILIST",X,0),U,5)'="":$PIECE(PSIVOI("DILIST",X,0),U,5),1:"N/A")_" "_" SCHEDULE: "_$SELECT($PIECE(PSIVOI("DILIST",X,0),U,6)'="":$PIECE(PSIVOI("DILIST"
,X,0),U,6),1:"N/A")
End DoDot:2
+10 IF '$TEST
Begin DoDot:2
+11 IF PSIVOI="AD"
SET $EXTRACT(DIR("A",X),40)="Additive Strength: "_$SELECT($PIECE(PSIVOI("DILIST",X,0),U,4)'="":$PIECE(PSIVOI("DILIST",X,0),U,4)_" "_$PIECE(PSIVOI("DILIST",X,0),U,3),1:"N/A")
End DoDot:2
End DoDot:1
+12 SET DIR("A")="Select (1 - "_+PSIVOI("DILIST",0)_"): "
+13 DO ^DIR
+14 IF +Y
Begin DoDot:1
+15 NEW PSIVOIND
SET PSIVOIND=PSIVOI("DILIST",+Y,0)
+16 WRITE " "_$PIECE(PSIVOIND,U,2)_$SELECT(PSIVOI="SOL":" "_$PIECE(PSIVOIND,U,3),1:"")
+17 SET ND=$GET(^PS($SELECT(PSIVOI="AD":52.6,1:52.7),+PSIVOIND,0))
+18 SET DRG(PSIVOI,0)=1
+19 SET DRG(PSIVOI,1)=+PSIVOIND_U_$PIECE(ND,U)_U_$SELECT(PSIVOI="SOL":$PIECE(ND,U,3),1:"")_U_U_$PIECE(ND,U,13)_U_$PIECE(ND,U,11)
+20 SET DRGI=1
DO SETDRG
+21 IF $PIECE(PSIVOI("DILIST",+Y,0),U,4)="QC"
IF DRGT="AD"
IF $DATA(^PS(52.6,"C",$PIECE(PSIVOI("DILIST",+Y,0),U,2),+PSIVOI("DILIST",+Y,0)))
Begin DoDot:2
+22 SET (X,PSIVX)=$PIECE(PSIVOI("DILIST",+Y,0),U,2)
SET (PSJIVIEN,Y)=+PSIVOI("DILIST",+Y,0)
Begin DoDot:3
+23 NEW PSJNF
DO NFIV^PSJDIN(52.6,+PSJIVIEN,.PSJNF)
WRITE PSJNF("NF")
+24 SET DRGTMP=DRG(DRGT,1)
+25 IF '$DATA(ON55)
NEW ON55
SET ON55=ON
+26 DO ORDERCHK(DFN,ON55,1)
IF $GET(PSGORQF)
SET X=U
SET DONE=1
QUIT
+27 DO DINIV^PSJDIN(52.6,+DRGTMP)
+28 DO ^PSIVQUI
End DoDot:3
End DoDot:2
if $GET(PSIVSTR)="QUICK CODE"!$GET(PSGORQF)
QUIT
+29 IF $PIECE(PSIVOI("DILIST",+Y,0),U,4)'="QC"
SET DRGTMP=DRG(DRGT,1)
DO ORDERCHK(DFN,ON55,1)
IF $GET(PSGORQF)
SET X=U
SET DONE=1
QUIT
+30 IF PSIVOI="AD"
Begin DoDot:2
+31 NEW FIL
SET FIL=52.6
DO DRG3
End DoDot:2
End DoDot:1
+32 KILL PSIVOI
+33 QUIT
