PSSPOIMN ;BIR/RTR/WRT-Orderable Item manual create ;29-May-2012 15:18;PLS
;;1.0;PHARMACY DATA MANAGEMENT;**15,32,34,38,51,57,1013,82,125,1015**;9/30/97;Build 62
;
;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
;
;Modified - IHS/MSC/MGH - 02/08/2012 - Line BEG+2
;
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")
;IHS/MSC/MGH changed for mixed case lookup, uses new cross-reference
;S PSOUT=0 W !! K DIC S DIC(0)="QEAM",DIC="^PSDRUG(",DIC("A")="Select DISPENSE DRUG: "
S PSOUT=0 W !! K DIC S DIC(0)="QEAM",D="BCAP",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):0 I '$T W !,$C(7),"Another person is editing this one." Q
D IX^DIC G:$D(DTOUT)!($D(DUOUT))!(Y<1) END K DIC("S") S PSIEN=+Y,PSNAME=$P(^PSDRUG(PSIEN,0),"^") L +^PSDRUG(PSIEN):0 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
Q:$G(PSOUT) I $O(^TMP($J,"PSSOO",0)),$G(MATCH) S PSSP=MATCH D ^PSSPOIM1 Q:(PSOUT)!(PSNO) S DIE="^PSDRUG(",DA=PSIEN,DR="2.1////"_MATCH D ^DIE K DIE S PSITEM=MATCH D COM Q
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
Q:$G(PSOUT) I $O(^TMP($J,"PSSOO",0)),$G(MATCH) S PSSP=MATCH D ^PSSPOIM1 Q:(PSOUT)!(PSNO) K DIE S DIE="^PSDRUG(",DA=PSIEN,DR="2.1////"_MATCH D ^DIE S PSITEM=MATCH D COM Q
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 Q:PSOUT!(STOP) K DIE S DIE="^PSDRUG(",DA=PSIEN,DR="2.1////"_COMM D ^DIE S PSITEM=COMM D COM S STOP=1 Q
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 W !!!?3,"Enter ?? for Pharmacy Orderable Item List!",!
K DIC S DIC="^PS(50.7,",DIC(0)="QEAM",DIC("S")="I $P($G(^(0)),""^"",2)=DOSEPTR,$P($G(^(0)),""^"",3)=""""" D ^DIC I Y>0 S (NEWSP,PSSP)=+Y D ^PSSPOIM1 G:PSNO LOOK Q:PSOUT S DIE="^PSDRUG(",DA=PSIEN,DR="2.1////"_NEWSP D ^DIE S PSITEM=NEWSP D COM Q
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
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
PSSPOIMN ;BIR/RTR/WRT-Orderable Item manual create ;29-May-2012 15:18;PLS
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**15,32,34,38,51,57,1013,82,125,1015**;9/30/97;Build 62
+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 ;Modified - IHS/MSC/MGH - 02/08/2012 - Line BEG+2
+8 ;
+9 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
+10 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 ;IHS/MSC/MGH changed for mixed case lookup, uses new cross-reference
+3 ;S PSOUT=0 W !! K DIC S DIC(0)="QEAM",DIC="^PSDRUG(",DIC("A")="Select DISPENSE DRUG: "
+4 SET PSOUT=0
WRITE !!
KILL DIC
SET DIC(0)="QEAM"
SET D="BCAP"
SET DIC="^PSDRUG("
SET DIC("A")="Select DISPENSE DRUG: "
+5 ;DIC("S")="I $P($G(^PSDRUG(+Y,2)),""^"",3)[""I""!($P($G(^(2)),""^"",3)[""O"")!($P($G(^(2)),""^"",3)[""U"")"
+6 ;D ^DIC G:$D(DTOUT)!($D(DUOUT))!(Y<1) END K DIC("S") S PSIEN=+Y,PSNAME=$P(^PSDRUG(PSIEN,0),"^") L +^PSDRUG(PSIEN):0 I '$T W !,$C(7),"Another person is editing this one." Q
+7 DO IX^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):0
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
IF $ORDER(^TMP($JOB,"PSSOO",0))
IF $GET(MATCH)
SET PSSP=MATCH
DO ^PSSPOIM1
IF (PSOUT)!(PSNO)
QUIT
SET DIE="^PSDRUG("
SET DA=PSIEN
SET DR="2.1////"_MATCH
DO ^DIE
KILL DIE
SET PSITEM=MATCH
DO COM
QUIT
+3 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 IF $ORDER(^TMP($JOB,"PSSOO",0))
HANG 1
DO OTHER^PSSPOIM1
DO DISP
+1 IF $GET(PSOUT)
QUIT
IF $ORDER(^TMP($JOB,"PSSOO",0))
IF $GET(MATCH)
SET PSSP=MATCH
DO ^PSSPOIM1
IF (PSOUT)!(PSNO)
QUIT
KILL DIE
SET DIE="^PSDRUG("
SET DA=PSIEN
SET DR="2.1////"_MATCH
DO ^DIE
SET PSITEM=MATCH
DO COM
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
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
+6 SET PSSP=COMM
DO ^PSSPOIM1
IF PSNO
SET STOP=1
IF PSOUT!(STOP)
QUIT
KILL DIE
SET DIE="^PSDRUG("
SET DA=PSIEN
SET DR="2.1////"_COMM
DO ^DIE
SET PSITEM=COMM
DO COM
SET STOP=1
QUIT
End DoDot:1
+7 IF PSOUT
QUIT
+8 IF STOP
IF $GET(PSNO)
GOTO MCHAN
+9 IF STOP
QUIT
+10 SET PSMAN=1
+11 DO ^PSSPOIM1
+12 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
+13 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
+14 QUIT
LOOK WRITE !!!?3,"Enter ?? for Pharmacy Orderable Item List!",!
+1 KILL DIC
SET DIC="^PS(50.7,"
SET DIC(0)="QEAM"
SET DIC("S")="I $P($G(^(0)),""^"",2)=DOSEPTR,$P($G(^(0)),""^"",3)="""""
DO ^DIC
IF Y>0
SET (NEWSP,PSSP)=+Y
DO ^PSSPOIM1
IF PSNO
GOTO LOOK
IF PSOUT
QUIT
SET DIE="^PSDRUG("
SET DA=PSIEN
SET DR="2.1////"_NEWSP
DO ^DIE
SET PSITEM=NEWSP
DO COM
QUIT
+2 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
+3 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
