PSSPOIMN ;BIR/RTR/WRT - Orderable Item manual create ;09/01/98
;;1.0;PHARMACY DATA MANAGEMENT;**15,32,34,38,51,57,82,125,189,220**;9/30/97;Build 4
;
;Reference to ^PS(59 supported by DBIA #1976
;Reference to $$PSJDF^PSNAPIS(P1,P3) supported by DBIA #2531
;Reference to $$VAGN^PSNAPIS(P1) supported by DBIA #2531
;
N PSSDONE
S PSSITE=+$O(^PS(59.7,0)) I +$P($G(^PS(59.7,PSSITE,80)),"^",2)<2 W !!?3,"Orderable Item Auto-Create has not been completed yet!",! K PSSITE,DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR Q
K PSSITE D MESS^PSSPOIM1
BEG I $D(PSIEN) L -^PSDRUG(PSIEN)
K PSSCROSS,DOSEFV,DOSEFORM,POINT,SPHOLD,NEWSP,PSVAR1,PSITEM,PSTOP,PSMASTER,DIC("S")
S PSOUT=0 W !! K DIC S DIC(0)="QEAM",DIC="^PSDRUG(",DIC("A")="Select DISPENSE DRUG: "
;DIC("S")="I $P($G(^PSDRUG(+Y,2)),""^"",3)[""I""!($P($G(^(2)),""^"",3)[""O"")!($P($G(^(2)),""^"",3)[""U"")"
D ^DIC G:$D(DTOUT)!($D(DUOUT))!(Y<1) END K DIC("S") S PSIEN=+Y,PSNAME=$P(^PSDRUG(PSIEN,0),"^") L +^PSDRUG(PSIEN):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I '$T W !,$C(7),"Another person is editing this one." Q
MAS I $G(PSMASTER) S PSOUT=0 N DOSEFV,DOSEFORM,POINT,SPHOLD,NEWSP,PSVAR1,PSITEM,PSTOP
S NODE=$G(^PSDRUG(PSIEN,"ND")),DOSEPTR=0,DA=$P(NODE,"^"),X=$$VAGN^PSNAPIS(DA),VAGEN=X I +$P(NODE,"^"),+$P(NODE,"^",3),VAGEN'=0 S K=$P(NODE,"^",3),X=$$PSJDF^PSNAPIS(DA,K),DOSEFV=X I DOSEFV'=0 D
.S DOSEPTR=$P(X,"^"),DOSEFORM=$P(X,"^",2)
D TMP
I +$P($G(^PSDRUG(PSIEN,2)),"^") S (POINT,PSITEM)=$P(^(2),"^") W !!,PSNAME," is already matched to",!!,?5,$P($G(^PS(50.7,POINT,0)),"^")_" "_$P($G(^PS(50.606,+$P($G(^(0)),"^",2),0)),"^"),!
;Warn user the Orderable Item is inactive. Display date and option to use.
I $G(POINT) N PSSIAD D
.S PSSIAD=$P($G(^PS(50.7,POINT,0)),"^",4) I $G(PSSIAD) S Y=PSSIAD D DD^%DT W !,"This Orderable Item has an Inactive Date. *** "_Y,!,"To modify the Orderable Item, use the 'Edit Orderable Item' option."
I $G(POINT) D W ! K DIR S DIR("B")="NO",DIR(0)="Y",DIR("A")="Do you want to match to a different Orderable Item" D ^DIR K DIR D:Y=1 MORE,SET,REM D SETX G:$G(PSMASTER) END G BEG
.K PSSDXLF
D MCH
G:'$G(PSMASTER) BEG
END I $D(PSIEN) I '$G(PSSHUIDG) D DRG^PSSHUIDG(PSIEN) D L -^PSDRUG(PSIEN)
.N XX,DVER,DNSNAM,DNSPORT,DMFU S XX=""
.F XX=0:0 S XX=$O(^PS(59,XX)) Q:'XX D
..S DVER=$$GET1^DIQ(59,XX_",",105,"I"),DMFU=$$GET1^DIQ(59,XX_",",105.2)
..I DVER="2.4" S DNSNAM=$$GET1^DIQ(59,XX_",",2006),DNSPORT=$$GET1^DIQ(59,XX_",",2007) I DNSNAM'=""&(DMFU="YES") D DRG^PSSDGUPD(PSIEN,"",DNSNAM,DNSPORT)
G END^PSSPOIM1
REM D TMP
I $O(^TMP($J,"PSSOO",0)) H 1 D OTHER^PSSPOIM1,DISP
I $G(PSOUT) Q
S PSSDONE=0
I $O(^TMP($J,"PSSOO",0)),$G(MATCH) D I PSSDONE Q
.S PSSP=MATCH D ^PSSPOIM1 Q:(PSOUT)!(PSNO)
.;Checking whether the Orderable Item would have duplicate IV Solution Volumes
.I $$CKDUPVOL(+MATCH,PSIEN) Q
.S DIE="^PSDRUG(",DA=PSIEN,DR="2.1////"_MATCH D ^DIE K DIE S PSITEM=MATCH,PSSDONE=1 D COM
G MCHA
TMP K ^TMP($J,"PSSOO") S PSCNT=0 I +$P(NODE,"^"),+$P(NODE,"^",3) F ZZ=0:0 S ZZ=$O(^PSDRUG("AND",+NODE,ZZ)) Q:'ZZ I +$P($G(^PSDRUG(ZZ,2)),"^"),$P(^PSDRUG(ZZ,2),"^")'=$G(POINT),$D(^PS(50.7,$P(^PSDRUG(ZZ,2),"^"),0)) S OTH=$G(^PSDRUG(ZZ,"ND")) D
.I +$P(OTH,"^"),+$P(OTH,"^",3),DOSEFV'=0 S DA=$P(OTH,"^"),K=$P(OTH,"^",3),X=$$PSJDF^PSNAPIS(DA,K),DOSA=X I DOSA'=0,DOSEFV=DOSA D
..S NOFLAG=0,TMPTR=$P(^PSDRUG(ZZ,2),"^") F FFF=0:0 S FFF=$O(^TMP($J,"PSSOO",FFF)) Q:'FFF I $P(^TMP($J,"PSSOO",FFF),"^")=TMPTR S NOFLAG=1
..I 'NOFLAG S PSCNT=PSCNT+1 S ^TMP($J,"PSSOO",PSCNT)=$P(^PSDRUG(ZZ,2),"^")_"^"_ZZ
Q
DISP S MATCH=0 F TT=0:0 S TT=$O(^TMP($J,"PSSOO",TT)) Q:'TT S SPT=$P(^TMP($J,"PSSOO",TT),"^") W !,TT," ",$P($G(^PS(50.7,SPT,0)),"^")_" "_$P($G(^PS(50.606,+$P($G(^(0)),"^",2),0)),"^") I $Y+5>IOSL D Q:Y=0 I Y="" S PSOUT=1 Q
.W ! K DIR S DIR(0)="E" D ^DIR I Y W @IOF W !,?3,"Dispense Drug -> ",PSNAME,!
DISPO Q:$G(PSOUT) W ! K DIR S DIR(0)="N",DIR("A")="Choose number of Orderable Item to match, or '^' to enter a new one" D ^DIR K DIR I Y=""!($D(DTOUT)) S PSOUT=1 Q
Q:Y["^" I '$D(^TMP($J,"PSSOO",+Y)) W !!,?5,"INVALID NUMBER" G DISPO
S MATCH=$P(^TMP($J,"PSSOO",+Y),"^") Q
S PSOUT=1 Q
MCH ;
I $O(^TMP($J,"PSSOO",0)) H 1 D OTHER^PSSPOIM1,DISP
I $G(PSOUT) Q
S PSSDONE=0
I $O(^TMP($J,"PSSOO",0)),$G(MATCH) D I PSSDONE Q
.S PSSP=MATCH D ^PSSPOIM1 I (PSOUT)!(PSNO) Q
.;Checking whether the Orderable Item would have duplicate IV Solution Volumes
.I $$CKDUPVOL(+MATCH,PSIEN) Q
.K DIE S DIE="^PSDRUG(",DA=PSIEN,DR="2.1////"_MATCH D ^DIE S PSITEM=MATCH D COM S PSSDONE=1
MCHA W ! I $G(DOSEFORM)'="" W !?3,"Dosage Form -> ",DOSEFORM,!! K DIR S DIR(0)="Y",DIR("B")="NO",DIR("A")="Match to another Orderable Item with same Dosage Form" D ^DIR G:Y=1 LOOK I Y["^"!(Y="")!($D(DTOUT)) Q
I $G(DOSEFORM)="" K DIC S DIC="^PS(50.606,",DIC(0)="QEAMZ",DIC("A")="Choose Dosage Form: " D ^DIC Q:$D(DTOUT)!($D(DUOUT))!(Y<1) S DOSEPTR=+Y W !!?3,"Dose Form -> ",$G(Y(0,0))
I $G(DOSEFORM)="" K DIR W ! S DIR(0)="Y",DIR("B")="NO",DIR("A")="Match to another Orderable Item with same Dosage Form" D ^DIR
I $G(DOSEFORM)="" Q:$D(DTOUT)!($D(DUOUT))!(Y<0) S DOSEFORM=$P(^PS(50.606,DOSEPTR,0),"^") G:Y>0 LOOK
MCHAN W !! I $L(VAGEN)>40 W !,"VA Generic Name -> ",VAGEN,!
W !,?3,"Dosage Form -> ",DOSEFORM,!,?3,"Dispense Drug -> ",PSNAME,!!
K DIR S DIR(0)="F^3:40",DIR("A")="Orderable Item Name" S:$L(VAGEN)>2&($L(VAGEN)<41) DIR("B")=VAGEN
D ^DIR Q:$D(DUOUT)!($D(DTOUT))!(Y["^")!(Y="")
I X[""""!($A(X)=45)!('(X'?1P.E))!(X?2"z".E) W $C(7),!!?5,"??" G MCHAN
S (X,SPHOLD)=Y,(STOP,PSNO)=0
F COMM=0:0 S COMM=$O(^PS(50.7,"ADF",SPHOLD,DOSEPTR,COMM)) Q:'COMM!(STOP)!($G(PSOUT)) I COMM,$P($G(^PS(50.7,COMM,0)),"^",3)="" D
.S PSSP=COMM D ^PSSPOIM1 S:PSNO STOP=1 I PSOUT!(STOP) Q
.;Checking whether the Orderable Item would have duplicate IV Solution Volumes
.I $$CKDUPVOL(+COMM,PSIEN) S PSOUT=1 Q
.K DIE S DIE="^PSDRUG(",DA=PSIEN,DR="2.1////"_COMM D ^DIE S PSITEM=COMM D COM S STOP=1
Q:PSOUT
I STOP,$G(PSNO) G MCHAN
Q:STOP
S PSMAN=1
D ^PSSPOIM1
G:PSNO MCHAN Q:PSOUT K DIC S DIC="^PS(50.7,",DIC(0)="L",X=SPHOLD,DIC("DR")=".02////"_DOSEPTR K DD,DO D FILE^DICN K DD,DO D:Y<1 G:(Y<1) MCHAN S NEWSP=+Y,DIE="^PSDRUG(",DA=PSIEN,DR="2.1////"_NEWSP D ^DIE S PSVAR1=1,PSITEM=NEWSP D COM Q
.W $C(7),!?5,"Invalid entry!",!! Q
Q
;
LOOK ;
N PSSDONE
W !!!?3,"Enter ?? for Pharmacy Orderable Item List!",!
K DIC S DIC="^PS(50.7,",DIC(0)="QEAM"
S DIC("S")="I $P($G(^(0)),""^"",2)=DOSEPTR,$P($G(^(0)),""^"",3)=""""" D ^DIC
S PSSDONE=0
I Y>0 D I PSSDONE Q
.S (NEWSP,PSSP)=+Y D ^PSSPOIM1 G:PSNO LOOK I PSOUT Q
.;Checking whether the Orderable Item would have duplicate IV Solution Volumes
.I $$CKDUPVOL(+NEWSP,PSIEN) Q
.S DIE="^PSDRUG(",DA=PSIEN,DR="2.1////"_NEWSP D ^DIE S PSITEM=NEWSP D COM S PSSDONE=1
I '$D(PSSNOOI) W ! K DIR S DIR(0)="Y",DIR("B")="YES",DIR("A")="Create a new Orderable Item to match" D ^DIR I Y=1 G MCHAN
K PSSNOOI
Q
COM W !,"Match Complete!",! D EN^PSSPOIM1(PSITEM) Q
;
SET ;
S PSSDXLF=1,PSSDXL=+$P($G(^PS(50.7,+$G(POINT),0)),"^",2)
Q
SETX ;
I $G(PSSDXLF),$G(PSSDXL),$G(PSITEM),$G(PSSDXL)'=+$P($G(^PS(50.7,+$G(PSITEM),0)),"^",2) K ^PSDRUG(PSIEN,"DOS2") I $G(PSIEN) D EN2^PSSUTIL(PSIEN,1)
K PSSDXL,PSSDXLF
Q
MORE ;Show Additives and Solutions
Q:'$G(PSIEN)
N PSSMORA,PSSMORS,PSSMZ,PSSMZOUT,PSSMODT
S (PSSMORA,PSSMORS,PSSMZOUT)=0
I $O(^PS(52.6,"AC",PSIEN,0)) S PSSMORA=1
I $O(^PS(52.7,"AC",PSIEN,0)) S PSSMORS=1
I 'PSSMORA,'PSSMORS Q
W !!!,"There are "_$S('$G(PSSMORS):"IV Additives",'$G(PSSMORA):"IV Solutions",1:"IV Additives and IV Solutions")_" tied to this Dispense Drug."
W !,"By rematching the Dispense Drug to a new Pharmacy Orderable Item, all of these",!,$S('$G(PSSMORS):"IV Additives",'$G(PSSMORA):"IV Solutions",1:"IV Additives and IV Solutions")_" will also be rematched to the new Orderable Item.",!
K DIR S DIR(0)="E",DIR("A")="Press Return to see "_$S('$G(PSSMORS):"IV Additive",'$G(PSSMORA):"IV Solution",1:"IV Additive/Solution")_" list" D ^DIR I Y'=1 W ! Q
W @IOF
W !,$S('$G(PSSMORA):"IV Solutions",'$G(PSSMORS):"IV Additives",1:"IV Additives/Solutions"),!,"------------" I $G(PSSMORS),$G(PSSMORA) W "----------"
I $G(PSSMORA) D G:$G(PSSMZOUT) MOREZ
.F PSSMZ=0:0 S PSSMZ=$O(^PS(52.6,"AC",PSIEN,PSSMZ)) Q:'PSSMZ!($G(PSSMZOUT)) D
..D:($Y+5)>IOSL MOREH Q:$G(PSSMZOUT)
..W !,$P($G(^PS(52.6,PSSMZ,0)),"^"),?42,"(A)"
..S PSSMODT=$P($G(^PS(52.6,PSSMZ,"I")),"^") I PSSMODT D MODT
;I $G(PSSMORA),$G(PSSMORS) W !
I $G(PSSMORS) D
.F PSSMZ=0:0 S PSSMZ=$O(^PS(52.7,"AC",PSIEN,PSSMZ)) Q:'PSSMZ!($G(PSSMZOUT)) D
..D:($Y+5)>IOSL MOREH Q:$G(PSSMZOUT)
..W !,$P($G(^PS(52.7,PSSMZ,0)),"^"),?31,$P($G(^(0)),"^",3),?42,"(S)"
..S PSSMODT=$P($G(^PS(52.7,PSSMZ,"I")),"^") I PSSMODT D MODT
MOREZ ;
I '$G(PSSMZOUT) W ! K DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR
Q
;
MOREH ;
W ! K DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR I 'Y S PSSMZOUT=1 Q
W @IOF
Q
MODT ;
S Y=$G(PSSMODT) I $G(Y) D DD^%DT W ?50,$G(Y) K Y
Q
;
CKDUPVOL(OIIEN,DRUGIEN) ; Checks OI to see if it will have duplicate IV Solution Volumes
; Input: OIIEN - PHARMACY ORDERABLE ITEM File (#50.7) IEN
; DRUGIEN - DRUG File (#50) IEN
;Output: DUPVOL - 0: No Duplicate Volume / 1: Duplicate Volume
N DUPVOL,IVSOL,PSSQUIT S (IVSOL,DUPVOL)=0
F S IVSOL=$O(^PS(52.7,"AC",DRUGIEN,IVSOL)) Q:'IVSOL D I DUPVOL Q
.; IV Solution field USED IN IV FLUID ORDER ENTRY set to 'NO'
.I '$$GET1^DIQ(52.7,IVSOL,17,"I") Q
.; IV Solution is INACTIVE, no issues
.I $$GET1^DIQ(52.7,IVSOL,8,"I"),$$GET1^DIQ(52.7,IVSOL,8,"I")'>DT Q
.I $$CKDUPSOL^PSSDDUT2(OIIEN,IVSOL,$$GET1^DIQ(52.7,IVSOL,2),0) D
..W !!,"Matching ",$$GET1^DIQ(50,DRUGIEN,.01)," to ",$$GET1^DIQ(50.7,OIIEN,.01)," would cause the"
..W !,"orderable item to have more than one Active IV Solution with the same volume"
..W !,"marked to be used in the IV FLUID ORDER ENTRY, which is not allowed."
..W !,""
..W !,"Please, review the IV Solutions associated with this drug before matching it"
..W !,"to this orderable item or match it to a different orderable item."
..S DUPVOL=1
Q DUPVOL
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSPOIMN 10180 printed Oct 16, 2024@18:34:46 Page 2
PSSPOIMN ;BIR/RTR/WRT - Orderable Item manual create ;09/01/98
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**15,32,34,38,51,57,82,125,189,220**;9/30/97;Build 4
+2 ;
+3 ;Reference to ^PS(59 supported by DBIA #1976
+4 ;Reference to $$PSJDF^PSNAPIS(P1,P3) supported by DBIA #2531
+5 ;Reference to $$VAGN^PSNAPIS(P1) supported by DBIA #2531
+6 ;
+7 NEW PSSDONE
+8 SET PSSITE=+$ORDER(^PS(59.7,0))
IF +$PIECE($GET(^PS(59.7,PSSITE,80)),"^",2)<2
WRITE !!?3,"Orderable Item Auto-Create has not been completed yet!",!
KILL PSSITE,DIR
SET DIR(0)="E"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
KILL DIR
QUIT
+9 KILL PSSITE
DO MESS^PSSPOIM1
BEG IF $DATA(PSIEN)
LOCK -^PSDRUG(PSIEN)
+1 KILL PSSCROSS,DOSEFV,DOSEFORM,POINT,SPHOLD,NEWSP,PSVAR1,PSITEM,PSTOP,PSMASTER,DIC("S")
+2 SET PSOUT=0
WRITE !!
KILL DIC
SET DIC(0)="QEAM"
SET DIC="^PSDRUG("
SET DIC("A")="Select DISPENSE DRUG: "
+3 ;DIC("S")="I $P($G(^PSDRUG(+Y,2)),""^"",3)[""I""!($P($G(^(2)),""^"",3)[""O"")!($P($G(^(2)),""^"",3)[""U"")"
+4 DO ^DIC
if $DATA(DTOUT)!($DATA(DUOUT))!(Y<1)
GOTO END
KILL DIC("S")
SET PSIEN=+Y
SET PSNAME=$PIECE(^PSDRUG(PSIEN,0),"^")
LOCK +^PSDRUG(PSIEN):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF '$TEST
WRITE !,$CHAR(7),"Another person is editing this one."
QUIT
MAS IF $GET(PSMASTER)
SET PSOUT=0
NEW DOSEFV,DOSEFORM,POINT,SPHOLD,NEWSP,PSVAR1,PSITEM,PSTOP
+1 SET NODE=$GET(^PSDRUG(PSIEN,"ND"))
SET DOSEPTR=0
SET DA=$PIECE(NODE,"^")
SET X=$$VAGN^PSNAPIS(DA)
SET VAGEN=X
IF +$PIECE(NODE,"^")
IF +$PIECE(NODE,"^",3)
IF VAGEN'=0
SET K=$PIECE(NODE,"^",3)
SET X=$$PSJDF^PSNAPIS(DA,K)
SET DOSEFV=X
IF DOSEFV'=0
Begin DoDot:1
+2 SET DOSEPTR=$PIECE(X,"^")
SET DOSEFORM=$PIECE(X,"^",2)
End DoDot:1
+3 DO TMP
+4 IF +$PIECE($GET(^PSDRUG(PSIEN,2)),"^")
SET (POINT,PSITEM)=$PIECE(^(2),"^")
WRITE !!,PSNAME," is already matched to",!!,?5,$PIECE($GET(^PS(50.7,POINT,0)),"^")_" "_$PIECE($GET(^PS(50.606,+$PIECE($GET(^(0)),"^",2),0)),"^"),!
+5 ;Warn user the Orderable Item is inactive. Display date and option to use.
+6 IF $GET(POINT)
NEW PSSIAD
Begin DoDot:1
+7 SET PSSIAD=$PIECE($GET(^PS(50.7,POINT,0)),"^",4)
IF $GET(PSSIAD)
SET Y=PSSIAD
DO DD^%DT
WRITE !,"This Orderable Item has an Inactive Date. *** "_Y,!,"To modify the Orderable Item, use the 'Edit Orderable Item' option."
End DoDot:1
+8 IF $GET(POINT)
Begin DoDot:1
+9 KILL PSSDXLF
End DoDot:1
WRITE !
KILL DIR
SET DIR("B")="NO"
SET DIR(0)="Y"
SET DIR("A")="Do you want to match to a different Orderable Item"
DO ^DIR
KILL DIR
if Y=1
DO MORE
DO SET
DO REM
DO SETX
if $GET(PSMASTER)
GOTO END
GOTO BEG
+10 DO MCH
+11 if '$GET(PSMASTER)
GOTO BEG
END IF $DATA(PSIEN)
IF '$GET(PSSHUIDG)
DO DRG^PSSHUIDG(PSIEN)
Begin DoDot:1
+1 NEW XX,DVER,DNSNAM,DNSPORT,DMFU
SET XX=""
+2 FOR XX=0:0
SET XX=$ORDER(^PS(59,XX))
if 'XX
QUIT
Begin DoDot:2
+3 SET DVER=$$GET1^DIQ(59,XX_",",105,"I")
SET DMFU=$$GET1^DIQ(59,XX_",",105.2)
+4 IF DVER="2.4"
SET DNSNAM=$$GET1^DIQ(59,XX_",",2006)
SET DNSPORT=$$GET1^DIQ(59,XX_",",2007)
IF DNSNAM'=""&(DMFU="YES")
DO DRG^PSSDGUPD(PSIEN,"",DNSNAM,DNSPORT)
End DoDot:2
End DoDot:1
LOCK -^PSDRUG(PSIEN)
+5 GOTO END^PSSPOIM1
REM DO TMP
+1 IF $ORDER(^TMP($JOB,"PSSOO",0))
HANG 1
DO OTHER^PSSPOIM1
DO DISP
+2 IF $GET(PSOUT)
QUIT
+3 SET PSSDONE=0
+4 IF $ORDER(^TMP($JOB,"PSSOO",0))
IF $GET(MATCH)
Begin DoDot:1
+5 SET PSSP=MATCH
DO ^PSSPOIM1
if (PSOUT)!(PSNO)
QUIT
+6 ;Checking whether the Orderable Item would have duplicate IV Solution Volumes
+7 IF $$CKDUPVOL(+MATCH,PSIEN)
QUIT
+8 SET DIE="^PSDRUG("
SET DA=PSIEN
SET DR="2.1////"_MATCH
DO ^DIE
KILL DIE
SET PSITEM=MATCH
SET PSSDONE=1
DO COM
End DoDot:1
IF PSSDONE
QUIT
+9 GOTO MCHA
TMP KILL ^TMP($JOB,"PSSOO")
SET PSCNT=0
IF +$PIECE(NODE,"^")
IF +$PIECE(NODE,"^",3)
FOR ZZ=0:0
SET ZZ=$ORDER(^PSDRUG("AND",+NODE,ZZ))
if 'ZZ
QUIT
IF +$PIECE($GET(^PSDRUG(ZZ,2)),"^")
IF $PIECE(^PSDRUG(ZZ,2),"^")'=$GET(POINT)
IF $DATA(^PS(50.7,$PIECE(^PSDRUG(ZZ,2),"^"),0))
SET OTH=$GET(^PSDRUG(ZZ,"ND"))
Begin DoDot:1
+1 IF +$PIECE(OTH,"^")
IF +$PIECE(OTH,"^",3)
IF DOSEFV'=0
SET DA=$PIECE(OTH,"^")
SET K=$PIECE(OTH,"^",3)
SET X=$$PSJDF^PSNAPIS(DA,K)
SET DOSA=X
IF DOSA'=0
IF DOSEFV=DOSA
Begin DoDot:2
+2 SET NOFLAG=0
SET TMPTR=$PIECE(^PSDRUG(ZZ,2),"^")
FOR FFF=0:0
SET FFF=$ORDER(^TMP($JOB,"PSSOO",FFF))
if 'FFF
QUIT
IF $PIECE(^TMP($JOB,"PSSOO",FFF),"^")=TMPTR
SET NOFLAG=1
+3 IF 'NOFLAG
SET PSCNT=PSCNT+1
SET ^TMP($JOB,"PSSOO",PSCNT)=$PIECE(^PSDRUG(ZZ,2),"^")_"^"_ZZ
End DoDot:2
End DoDot:1
+4 QUIT
DISP SET MATCH=0
FOR TT=0:0
SET TT=$ORDER(^TMP($JOB,"PSSOO",TT))
if 'TT
QUIT
SET SPT=$PIECE(^TMP($JOB,"PSSOO",TT),"^")
WRITE !,TT," ",$PIECE($GET(^PS(50.7,SPT,0)),"^")_" "_$PIECE($GET(^PS(50.606,+$PIECE($GET(^(0)),"^",2),0)),"^")
IF $Y+5>IOSL
Begin DoDot:1
+1 WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
IF Y
WRITE @IOF
WRITE !,?3,"Dispense Drug -> ",PSNAME,!
End DoDot:1
if Y=0
QUIT
IF Y=""
SET PSOUT=1
QUIT
DISPO if $GET(PSOUT)
QUIT
WRITE !
KILL DIR
SET DIR(0)="N"
SET DIR("A")="Choose number of Orderable Item to match, or '^' to enter a new one"
DO ^DIR
KILL DIR
IF Y=""!($DATA(DTOUT))
SET PSOUT=1
QUIT
+1 if Y["^"
QUIT
IF '$DATA(^TMP($JOB,"PSSOO",+Y))
WRITE !!,?5,"INVALID NUMBER"
GOTO DISPO
+2 SET MATCH=$PIECE(^TMP($JOB,"PSSOO",+Y),"^")
QUIT
+3 SET PSOUT=1
QUIT
MCH ;
+1 IF $ORDER(^TMP($JOB,"PSSOO",0))
HANG 1
DO OTHER^PSSPOIM1
DO DISP
+2 IF $GET(PSOUT)
QUIT
+3 SET PSSDONE=0
+4 IF $ORDER(^TMP($JOB,"PSSOO",0))
IF $GET(MATCH)
Begin DoDot:1
+5 SET PSSP=MATCH
DO ^PSSPOIM1
IF (PSOUT)!(PSNO)
QUIT
+6 ;Checking whether the Orderable Item would have duplicate IV Solution Volumes
+7 IF $$CKDUPVOL(+MATCH,PSIEN)
QUIT
+8 KILL DIE
SET DIE="^PSDRUG("
SET DA=PSIEN
SET DR="2.1////"_MATCH
DO ^DIE
SET PSITEM=MATCH
DO COM
SET PSSDONE=1
End DoDot:1
IF PSSDONE
QUIT
MCHA WRITE !
IF $GET(DOSEFORM)'=""
WRITE !?3,"Dosage Form -> ",DOSEFORM,!!
KILL DIR
SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Match to another Orderable Item with same Dosage Form"
DO ^DIR
if Y=1
GOTO LOOK
IF Y["^"!(Y="")!($DATA(DTOUT))
QUIT
+1 IF $GET(DOSEFORM)=""
KILL DIC
SET DIC="^PS(50.606,"
SET DIC(0)="QEAMZ"
SET DIC("A")="Choose Dosage Form: "
DO ^DIC
if $DATA(DTOUT)!($DATA(DUOUT))!(Y<1)
QUIT
SET DOSEPTR=+Y
WRITE !!?3,"Dose Form -> ",$GET(Y(0,0))
+2 IF $GET(DOSEFORM)=""
KILL DIR
WRITE !
SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Match to another Orderable Item with same Dosage Form"
DO ^DIR
+3 IF $GET(DOSEFORM)=""
if $DATA(DTOUT)!($DATA(DUOUT))!(Y<0)
QUIT
SET DOSEFORM=$PIECE(^PS(50.606,DOSEPTR,0),"^")
if Y>0
GOTO LOOK
MCHAN WRITE !!
IF $LENGTH(VAGEN)>40
WRITE !,"VA Generic Name -> ",VAGEN,!
+1 WRITE !,?3,"Dosage Form -> ",DOSEFORM,!,?3,"Dispense Drug -> ",PSNAME,!!
+2 KILL DIR
SET DIR(0)="F^3:40"
SET DIR("A")="Orderable Item Name"
if $LENGTH(VAGEN)>2&($LENGTH(VAGEN)<41)
SET DIR("B")=VAGEN
+3 DO ^DIR
if $DATA(DUOUT)!($DATA(DTOUT))!(Y["^")!(Y="")
QUIT
+4 IF X[""""!($ASCII(X)=45)!('(X'?1P.E))!(X?2"z".E)
WRITE $CHAR(7),!!?5,"??"
GOTO MCHAN
+5 SET (X,SPHOLD)=Y
SET (STOP,PSNO)=0
+6 FOR COMM=0:0
SET COMM=$ORDER(^PS(50.7,"ADF",SPHOLD,DOSEPTR,COMM))
if 'COMM!(STOP)!($GET(PSOUT))
QUIT
IF COMM
IF $PIECE($GET(^PS(50.7,COMM,0)),"^",3)=""
Begin DoDot:1
+7 SET PSSP=COMM
DO ^PSSPOIM1
if PSNO
SET STOP=1
IF PSOUT!(STOP)
QUIT
+8 ;Checking whether the Orderable Item would have duplicate IV Solution Volumes
+9 IF $$CKDUPVOL(+COMM,PSIEN)
SET PSOUT=1
QUIT
+10 KILL DIE
SET DIE="^PSDRUG("
SET DA=PSIEN
SET DR="2.1////"_COMM
DO ^DIE
SET PSITEM=COMM
DO COM
SET STOP=1
End DoDot:1
+11 if PSOUT
QUIT
+12 IF STOP
IF $GET(PSNO)
GOTO MCHAN
+13 if STOP
QUIT
+14 SET PSMAN=1
+15 DO ^PSSPOIM1
+16 if PSNO
GOTO MCHAN
if PSOUT
QUIT
KILL DIC
SET DIC="^PS(50.7,"
SET DIC(0)="L"
SET X=SPHOLD
SET DIC("DR")=".02////"_DOSEPTR
KILL DD,DO
DO FILE^DICN
KILL DD,DO
if Y<1
Begin DoDot:1
+17 WRITE $CHAR(7),!?5,"Invalid entry!",!!
QUIT
End DoDot:1
if (Y<1)
GOTO MCHAN
SET NEWSP=+Y
SET DIE="^PSDRUG("
SET DA=PSIEN
SET DR="2.1////"_NEWSP
DO ^DIE
SET PSVAR1=1
SET PSITEM=NEWSP
DO COM
QUIT
+18 QUIT
+19 ;
LOOK ;
+1 NEW PSSDONE
+2 WRITE !!!?3,"Enter ?? for Pharmacy Orderable Item List!",!
+3 KILL DIC
SET DIC="^PS(50.7,"
SET DIC(0)="QEAM"
+4 SET DIC("S")="I $P($G(^(0)),""^"",2)=DOSEPTR,$P($G(^(0)),""^"",3)="""""
DO ^DIC
+5 SET PSSDONE=0
+6 IF Y>0
Begin DoDot:1
+7 SET (NEWSP,PSSP)=+Y
DO ^PSSPOIM1
if PSNO
GOTO LOOK
IF PSOUT
QUIT
+8 ;Checking whether the Orderable Item would have duplicate IV Solution Volumes
+9 IF $$CKDUPVOL(+NEWSP,PSIEN)
QUIT
+10 SET DIE="^PSDRUG("
SET DA=PSIEN
SET DR="2.1////"_NEWSP
DO ^DIE
SET PSITEM=NEWSP
DO COM
SET PSSDONE=1
End DoDot:1
IF PSSDONE
QUIT
+11 IF '$DATA(PSSNOOI)
WRITE !
KILL DIR
SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Create a new Orderable Item to match"
DO ^DIR
IF Y=1
GOTO MCHAN
+12 KILL PSSNOOI
+13 QUIT
COM WRITE !,"Match Complete!",!
DO EN^PSSPOIM1(PSITEM)
QUIT
+1 ;
SET ;
+1 SET PSSDXLF=1
SET PSSDXL=+$PIECE($GET(^PS(50.7,+$GET(POINT),0)),"^",2)
+2 QUIT
SETX ;
+1 IF $GET(PSSDXLF)
IF $GET(PSSDXL)
IF $GET(PSITEM)
IF $GET(PSSDXL)'=+$PIECE($GET(^PS(50.7,+$GET(PSITEM),0)),"^",2)
KILL ^PSDRUG(PSIEN,"DOS2")
IF $GET(PSIEN)
DO EN2^PSSUTIL(PSIEN,1)
+2 KILL PSSDXL,PSSDXLF
+3 QUIT
MORE ;Show Additives and Solutions
+1 if '$GET(PSIEN)
QUIT
+2 NEW PSSMORA,PSSMORS,PSSMZ,PSSMZOUT,PSSMODT
+3 SET (PSSMORA,PSSMORS,PSSMZOUT)=0
+4 IF $ORDER(^PS(52.6,"AC",PSIEN,0))
SET PSSMORA=1
+5 IF $ORDER(^PS(52.7,"AC",PSIEN,0))
SET PSSMORS=1
+6 IF 'PSSMORA
IF 'PSSMORS
QUIT
+7 WRITE !!!,"There are "_$SELECT('$GET(PSSMORS):"IV Additives",'$GET(PSSMORA):"IV Solutions",1:"IV Additives and IV Solutions")_" tied to this Dispense Drug."
+8 WRITE !,"By rematching the Dispense Drug to a new Pharmacy Orderable Item, all of these",!,$SELECT('$GET(PSSMORS):"IV Additives",'$GET(PSSMORA):"IV Solutions",1:"IV Additives and IV Solutions")_" will also be rematched to the new Orderable Item
.",!
+9 KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to see "_$SELECT('$GET(PSSMORS):"IV Additive",'$GET(PSSMORA):"IV Solution",1:"IV Additive/Solution")_" list"
DO ^DIR
IF Y'=1
WRITE !
QUIT
+10 WRITE @IOF
+11 WRITE !,$SELECT('$GET(PSSMORA):"IV Solutions",'$GET(PSSMORS):"IV Additives",1:"IV Additives/Solutions"),!,"------------"
IF $GET(PSSMORS)
IF $GET(PSSMORA)
WRITE "----------"
+12 IF $GET(PSSMORA)
Begin DoDot:1
+13 FOR PSSMZ=0:0
SET PSSMZ=$ORDER(^PS(52.6,"AC",PSIEN,PSSMZ))
if 'PSSMZ!($GET(PSSMZOUT))
QUIT
Begin DoDot:2
+14 if ($Y+5)>IOSL
DO MOREH
if $GET(PSSMZOUT)
QUIT
+15 WRITE !,$PIECE($GET(^PS(52.6,PSSMZ,0)),"^"),?42,"(A)"
+16 SET PSSMODT=$PIECE($GET(^PS(52.6,PSSMZ,"I")),"^")
IF PSSMODT
DO MODT
End DoDot:2
End DoDot:1
if $GET(PSSMZOUT)
GOTO MOREZ
+17 ;I $G(PSSMORA),$G(PSSMORS) W !
+18 IF $GET(PSSMORS)
Begin DoDot:1
+19 FOR PSSMZ=0:0
SET PSSMZ=$ORDER(^PS(52.7,"AC",PSIEN,PSSMZ))
if 'PSSMZ!($GET(PSSMZOUT))
QUIT
Begin DoDot:2
+20 if ($Y+5)>IOSL
DO MOREH
if $GET(PSSMZOUT)
QUIT
+21 WRITE !,$PIECE($GET(^PS(52.7,PSSMZ,0)),"^"),?31,$PIECE($GET(^(0)),"^",3),?42,"(S)"
+22 SET PSSMODT=$PIECE($GET(^PS(52.7,PSSMZ,"I")),"^")
IF PSSMODT
DO MODT
End DoDot:2
End DoDot:1
MOREZ ;
+1 IF '$GET(PSSMZOUT)
WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
KILL DIR
+2 QUIT
+3 ;
MOREH ;
+1 WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
KILL DIR
IF 'Y
SET PSSMZOUT=1
QUIT
+2 WRITE @IOF
+3 QUIT
MODT ;
+1 SET Y=$GET(PSSMODT)
IF $GET(Y)
DO DD^%DT
WRITE ?50,$GET(Y)
KILL Y
+2 QUIT
+3 ;
CKDUPVOL(OIIEN,DRUGIEN) ; Checks OI to see if it will have duplicate IV Solution Volumes
+1 ; Input: OIIEN - PHARMACY ORDERABLE ITEM File (#50.7) IEN
+2 ; DRUGIEN - DRUG File (#50) IEN
+3 ;Output: DUPVOL - 0: No Duplicate Volume / 1: Duplicate Volume
+4 NEW DUPVOL,IVSOL,PSSQUIT
SET (IVSOL,DUPVOL)=0
+5 FOR
SET IVSOL=$ORDER(^PS(52.7,"AC",DRUGIEN,IVSOL))
if 'IVSOL
QUIT
Begin DoDot:1
+6 ; IV Solution field USED IN IV FLUID ORDER ENTRY set to 'NO'
+7 IF '$$GET1^DIQ(52.7,IVSOL,17,"I")
QUIT
+8 ; IV Solution is INACTIVE, no issues
+9 IF $$GET1^DIQ(52.7,IVSOL,8,"I")
IF $$GET1^DIQ(52.7,IVSOL,8,"I")'>DT
QUIT
+10 IF $$CKDUPSOL^PSSDDUT2(OIIEN,IVSOL,$$GET1^DIQ(52.7,IVSOL,2),0)
Begin DoDot:2
+11 WRITE !!,"Matching ",$$GET1^DIQ(50,DRUGIEN,.01)," to ",$$GET1^DIQ(50.7,OIIEN,.01)," would cause the"
+12 WRITE !,"orderable item to have more than one Active IV Solution with the same volume"
+13 WRITE !,"marked to be used in the IV FLUID ORDER ENTRY, which is not allowed."
+14 WRITE !,""
+15 WRITE !,"Please, review the IV Solutions associated with this drug before matching it"
+16 WRITE !,"to this orderable item or match it to a different orderable item."
+17 SET DUPVOL=1
End DoDot:2
End DoDot:1
IF DUPVOL
QUIT
+18 QUIT DUPVOL
