ORCMEDT9 ;ISP/WAT - Move/copy utility for QOs ;08/03/16 11:56
;;3.0;ORDER ENTRY/RESULTS REPORTING;**389,423,397**;Dec 17, 1997;Build 22
UDQO ; -- unit dose quick order
N ORQDLG,ORDG,ORCMDG,ORCIDG,ORABORT,ORPMAX,ORINDEX
N ORSTART S ORSTART=""
S ORABORT=0,ORPMAX=IOSL-5,ORINDEX=""
S ORCMDG=$O(^ORD(100.98,"B","CLINIC MEDICATIONS",""))
S ORCIDG=$O(^ORD(100.98,"B","CLINIC INFUSIONS",""))
I +$G(ORCMDG)'>0 W !,"Abort: Clinic Medications display group not found!" Q
I +$G(ORCIDG)'>0 W !,"Abort: Clinic Infusions display group not found!" Q
D BLDUDQO
F D Q:ORABORT=1
. D DISP(ORPMAX,.ORINDEX)
. D CHOOSE(.ORABORT)
D CLEAN^DILF
Q
;
CHOOSE(ORABORT) ;select qo for action
N ORACT
N DIR,X,Y,DIRUT,DTOUT,DUOUT
S DIR(0)="LO"
D ^DIR
I $D(DTOUT) S ORABORT=1 Q
I $D(DUOUT) S ORABORT=1 Q
Q:X=""
I X'[","&(X'["-")&($D(^TMP("ORUDQO",$J,X))) D Q ;single selection can Move OR Copy
. S ORACT=$$ACTASK
. I ORACT="^" S ORABORT=1 Q
. E D ACTION(ORACT,X)
I X[","!(X["-") D ACTION(1,Y) ;check for series of numbers. Move only
Q
;
ACTION(ORGO,ORNUMBER) ;
;ORGO=1 MOVE, ORGO=2 COPY
N ORTEMP,ORCOUNT
S ORINDEX=ORSTART-1 ;if user comes to action, try to return them to list in the same set of QOS i.e. #21-40
I $G(ORGO)=2 D COPY(ORNUMBER) Q
I '$$MOVOK() Q
W !,"Moving selected quick order(s)..." H 5
S:$G(ORCMDG)="" ORCMDG=$O(^ORD(100.98,"B","CLINIC MEDICATIONS",""))
S ORCOUNT=1
F S ORTEMP=$P(ORNUMBER,",",ORCOUNT) Q:$G(ORTEMP)="" D
. I $D(^TMP("ORUDQO",$J,ORTEMP)) D MOVE(ORTEMP)
. S ORCOUNT=ORCOUNT+1
W " Done!" H 2
Q
;
DISP(ORPMAX,ORINDEX) ; show qo dialogs for action choices
N ORDLGNM,ORIFN,ORQONAM,ORDISABL,ORDG
D HEADER
S ORIFN=""
F S ORINDEX=$O(^TMP("ORUDQO",$J,ORINDEX)) Q:ORINDEX="" D Q:$Y>ORPMAX
. I IOSL-$Y<5 D HEADER
. S ORQONAM=$P(^TMP("ORUDQO",$J,ORINDEX),U,2),ORQONAM=$E(ORQONAM,1,45)
. S ORDG=$P(^TMP("ORUDQO",$J,ORINDEX),U,3)
. S ORDISABL=$P(^TMP("ORUDQO",$J,ORINDEX),U,4)
. W !,$J(ORINDEX,5)_". "_ORQONAM,?60,ORDG,?70,ORDISABL
S ORSTART=ORINDEX-ORPMAX
Q
;
MOVE(ORQDLG) ;Move changes the DISPLAY GROUP to CLINIC MEDICATIONS or CLINIC INFUSIONS
;ORQDLG is the index from ^TMP("ORUDQO",$J,index)=order dialog ifn^order NAME(.01)^DisplayGroup^Disabled
N ORIFN,ORCONVDG S ORIFN=$P(^TMP("ORUDQO",$J,ORQDLG),U) Q:$G(ORIFN)=""
I $D(^ORD(101.41,ORIFN,0)) D Q
. S ORCONVDG=$P(^TMP("ORUDQO",$J,ORQDLG),U,3)
. S ORCONVDG=$S(ORCONVDG="UDM":ORCMDG,1:ORCIDG)
. S $P(^ORD(101.41,ORIFN,0),U,5)=$G(ORCONVDG)
. I $D(^TMP("ORUDQO",$J,ORQDLG)) K ^TMP("ORUDQO",$J,ORQDLG)
E D
. W $C(7),!,"Abort: Order dialog not found - check file entry and try again."
. W !,"Order Dialog: "_$P(^ORD(101.41,ORIFN,0),U)
Q
COPY(ORQDLG) ;copy creates a new CLINIC MEDICATIONS or CLINIC INFUSIONS qo dialog and will ask to delete the original qo
;ORQDLG is the index from ^TMP("ORUDQO",$J,index)=order dialog ifn^order NAME(.01)^DisplayGroup^Disabled
N ORQIFN,ORNUNAME,ORNUIFN,ORCUR0,ORESULT,ORPOINT,OR30350,ORTMPDLG,ORDIGP
S OR30350=$$PATCH^XPDUTL("OR*3.0*350") ;no delete if 350 not installed
S ORQIFN=$P(^TMP("ORUDQO",$J,ORQDLG),U) Q:+$G(ORQIFN)'>0
S ORDIGP=$P(^TMP("ORUDQO",$J,ORQDLG),U,3)
S ORDIGP=$S(ORDIGP="UDM":ORCMDG,1:ORCIDG)
Q:'$D(^ORD(101.41,ORQIFN,0))
S ORNUNAME=$$GETNAME() I $G(ORNUNAME)="^" S ORQDLG=ORNUNAME Q
S ORNUIFN=$$STUB(101.41,ORNUNAME) I +$G(ORNUIFN)'>0 W !,"Error creating new entry. Please try again later." Q
N I,DA,DIE,DR,DIK,ORTEMP
S ORCUR0=^ORD(101.41,ORQIFN,0) ;get 0 node of current QO
F I=2,4,6,8,9 S $P(^ORD(101.41,ORNUIFN,0),U,I)=$P(ORCUR0,U,I)
S $P(^ORD(101.41,ORNUIFN,0),U,5)=$G(ORDIGP)
S:$L($P(ORCUR0,U,2)) ^ORD(101.41,"C",$$UP^XLFSTR($P(ORCUR0,U,2)),ORNUIFN)="" ;disp text
F I=2,3,3.1,4,5,6,7,9,10 I $D(^ORD(101.41,ORQIFN,I)) M ^ORD(101.41,ORNUIFN,I)=^ORD(101.41,ORQIFN,I)
I $P(ORCUR0,U,7) S ORTEMP=$P(ORCUR0,U,7),DA=ORNUIFN,DIE="^ORD(101.41,",DR="7///^S X=ORTEMP;99///^S X=$H" D ^DIE
K DA S DA(1)=ORNUIFN,DIK="^ORD(101.41,"_ORNUIFN_",10,",DIK(1)="2^AD" D ENALL^DIK
W !!," Quick order copy complete."
I ($G(OR30350)=1) D Q
. I '$$DELOK() D Q
. . W !,"OK - If desired, you can manually delete the QO via the QO editor."
. . S ORQDLG="^" D CONT("using the conversion utility")
. S ORPOINT=$$PTRCHECK(ORQIFN) I +$G(ORPOINT)>0 D Q
. . S ORQDLG="^" D CONT("using the conversion utility")
. Q:$G(ORQDLG)="^"
. W !,"Now deleting original quick order..."
. S ORESULT=$$DELETE(ORQIFN)
. I $G(ORESULT)'="@" W !,"Error deleting IEN "_ORQIFN_" from ORDER DIALOG (101.41)."
. E I $D(^TMP("ORUDQO",$J,ORQDLG)) K ^TMP("ORUDQO",$J,ORQDLG)
Q
;
BLDUDQO ;build list of UDM and IVM qos
N ORUDMDG,ORIVMED,ORDLGNM,ORIFN,ORINDEX,ORDISABL,ORDG
S ORINDEX=1,ORDLGNM=""
S ORUDMDG=$O(^ORD(100.98,"B","UNIT DOSE MEDICATIONS",""))
S ORIVMED=$O(^ORD(100.98,"B","IV MEDICATIONS",""))
Q:$G(ORUDMDG)=""!($G(ORIVMED)="")
K ^TMP("ORUDQO",$J)
F S ORDLGNM=$O(^ORD(101.41,"B",ORDLGNM)) Q:$G(ORDLGNM)="" D
. S ORIFN=$O(^ORD(101.41,"B",ORDLGNM,""))
. Q:+$G(ORIFN)'>0
. Q:$P($G(^ORD(101.41,ORIFN,0)),U,5)'=ORUDMDG&($P($G(^ORD(101.41,ORIFN,0)),U,5)'=ORIVMED)!($P($G(^ORD(101.41,ORIFN,0)),U,5)="")
. Q:$P($G(^(0)),U,4)'="Q"
. Q:$E($P($G(^(0)),U),1,6)="ORWDQ "
. S ORDISABL=$P($G(^(0)),U,3)
. S ORDG=$P($G(^(0)),U,5) S ORDG=$S(ORDG=ORUDMDG:"UDM",ORDG=ORIVMED:"IVM",1:"")
. S ORDISABL=$S($L($G(ORDISABL))>0:"YES",1:"")
. S ^TMP("ORUDQO",$J,ORINDEX)=ORIFN_"^"_$P(^ORD(101.41,ORIFN,0),U)_"^"_ORDG_"^"_ORDISABL,ORINDEX=ORINDEX+1
Q
;
GETNAME() ;get new name for copied dialog
N DIR,X,Y ;prompt for new NAME .01
S DIR(0)="F^3:63^",DIR("A")="NAME"
S DIR("?")="Enter a NAME (between 3 and 63 characters) for the new order dialog."
NM D ^DIR
I $D(DIRUT)!($D(DUOUT)) S Y="^" Q Y
I $O(^ORD(101.41,"AB",X,""))'="" W $C(7),!,"Another entry already exists by this name!",! S X="" G NM
K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>63!($L(X)<3)!'(X'?1P.E) X
I '$D(X) G NM
Q Y
PTRCHECK(ORIEN) ; check for pointers if Copy action
N IHAZPTR S IHAZPTR=0
I $D(^ORD(101.41,"AD",ORIEN)) S IHAZPTR=1 W $C(7),!,"Cannot delete order dialog - currently in use!",! Q IHAZPTR
S IHAZPTR=$$PTRCHK^ORCMEDT4(ORIEN,"QO PTRS")
I IHAZPTR D
. W $C(7),!,"Cannot delete order dialog - other file entries point to this order dialog!",!
. D CONT("reviewing pointer report")
. D PTRRPT^ORCMEDT4("QO PTRS",ORIEN)
Q IHAZPTR
;
ACTASK() ; get action Move or Copy
N DIR,X,Y
S DIR(0)="S^1:MOVE;2:COPY"
S DIR("?")="Choose an action for this quick order"
S DIR("?",1)="Move converts the selected QO into a new Clinic Medication QO."
S DIR("?",2)="Copy clones the selected QO into a new Clinic Medication QO."
S DIR("?",3)="The original QO is then deleted."
D ^DIR
S:$D(DTOUT)!($D(DUOUT)) Y="^"
Q Y
;
DELETE(IFN) ;remove old QO;
N Y,DA,DIK,IDX1,IDX2 S (IDX1,Y)=0
F S IDX1=$O(^ORD(101.44,"C",IFN,IDX1)) Q:'IDX1 D
. S IDX2=0
. F S IDX2=$O(^ORD(101.44,"C",IFN,IDX1,IDX2)) Q:'IDX2 D
. . S DA=IDX2,DA(1)=IDX1,DIK="^ORD(101.44,"_IDX1_",10," D ^DIK
K DA S DA=IFN,DIK="^ORD(101.41," D ^DIK W " ...deleted." S Y="@"
Q Y
;
STUB(ORFILE,ORNAME) ; create new entry in file
N FDA,MSG,IEN
S FDA(ORFILE,"+1,",.01)=ORNAME
D UPDATE^DIE("","FDA","IEN","MSG")
I $D(MSG)>0
D CLEAN^DILF
Q IEN(1)
;
CONT(MSG) ; -- gives user a chance to read output from pointer check
N X,Y,DIR
S DIR(0)="FO",DIR("A")="Press any key to continue "_MSG
S DIR("?")="Enter any key to continue; enter ^ to exit."
D ^DIR
Q
DELOK() ; -- Are you ready?
N X,Y,DIR
S DIR(0)="YA",DIR("A")="Do you want to delete the original quick order? ",DIR("B")="NO"
W ! D ^DIR
Q +Y
MOVOK() ; -- Are you ready?
N X,Y,DIR
S DIR(0)="YA",DIR("A")="Do you want to MOVE the selected quick order(s)? ",DIR("B")="NO"
W ! D ^DIR
Q +Y
W @IOF
W ".......Quick Order",$$REPEAT^XLFSTR(".",42),?60,"Type...",?67,"Disabled....."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORCMEDT9 7944 printed Dec 13, 2024@02:28:43 Page 2
ORCMEDT9 ;ISP/WAT - Move/copy utility for QOs ;08/03/16 11:56
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**389,423,397**;Dec 17, 1997;Build 22
UDQO ; -- unit dose quick order
+1 NEW ORQDLG,ORDG,ORCMDG,ORCIDG,ORABORT,ORPMAX,ORINDEX
+2 NEW ORSTART
SET ORSTART=""
+3 SET ORABORT=0
SET ORPMAX=IOSL-5
SET ORINDEX=""
+4 SET ORCMDG=$ORDER(^ORD(100.98,"B","CLINIC MEDICATIONS",""))
+5 SET ORCIDG=$ORDER(^ORD(100.98,"B","CLINIC INFUSIONS",""))
+6 IF +$GET(ORCMDG)'>0
WRITE !,"Abort: Clinic Medications display group not found!"
QUIT
+7 IF +$GET(ORCIDG)'>0
WRITE !,"Abort: Clinic Infusions display group not found!"
QUIT
+8 DO BLDUDQO
+9 FOR
Begin DoDot:1
+10 DO DISP(ORPMAX,.ORINDEX)
+11 DO CHOOSE(.ORABORT)
End DoDot:1
if ORABORT=1
QUIT
+12 DO CLEAN^DILF
+13 QUIT
+14 ;
CHOOSE(ORABORT) ;select qo for action
+1 NEW ORACT
+2 NEW DIR,X,Y,DIRUT,DTOUT,DUOUT
+3 SET DIR(0)="LO"
+4 DO ^DIR
+5 IF $DATA(DTOUT)
SET ORABORT=1
QUIT
+6 IF $DATA(DUOUT)
SET ORABORT=1
QUIT
+7 if X=""
QUIT
+8 ;single selection can Move OR Copy
IF X'[","&(X'["-")&($DATA(^TMP("ORUDQO",$JOB,X)))
Begin DoDot:1
+9 SET ORACT=$$ACTASK
+10 IF ORACT="^"
SET ORABORT=1
QUIT
+11 IF '$TEST
DO ACTION(ORACT,X)
End DoDot:1
QUIT
+12 ;check for series of numbers. Move only
IF X[","!(X["-")
DO ACTION(1,Y)
+13 QUIT
+14 ;
ACTION(ORGO,ORNUMBER) ;
+1 ;ORGO=1 MOVE, ORGO=2 COPY
+2 NEW ORTEMP,ORCOUNT
+3 ;if user comes to action, try to return them to list in the same set of QOS i.e. #21-40
SET ORINDEX=ORSTART-1
+4 IF $GET(ORGO)=2
DO COPY(ORNUMBER)
QUIT
+5 IF '$$MOVOK()
QUIT
+6 WRITE !,"Moving selected quick order(s)..."
HANG 5
+7 if $GET(ORCMDG)=""
SET ORCMDG=$ORDER(^ORD(100.98,"B","CLINIC MEDICATIONS",""))
+8 SET ORCOUNT=1
+9 FOR
SET ORTEMP=$PIECE(ORNUMBER,",",ORCOUNT)
if $GET(ORTEMP)=""
QUIT
Begin DoDot:1
+10 IF $DATA(^TMP("ORUDQO",$JOB,ORTEMP))
DO MOVE(ORTEMP)
+11 SET ORCOUNT=ORCOUNT+1
End DoDot:1
+12 WRITE " Done!"
HANG 2
+13 QUIT
+14 ;
DISP(ORPMAX,ORINDEX) ; show qo dialogs for action choices
+1 NEW ORDLGNM,ORIFN,ORQONAM,ORDISABL,ORDG
+2 DO HEADER
+3 SET ORIFN=""
+4 FOR
SET ORINDEX=$ORDER(^TMP("ORUDQO",$JOB,ORINDEX))
if ORINDEX=""
QUIT
Begin DoDot:1
+5 IF IOSL-$Y<5
DO HEADER
+6 SET ORQONAM=$PIECE(^TMP("ORUDQO",$JOB,ORINDEX),U,2)
SET ORQONAM=$EXTRACT(ORQONAM,1,45)
+7 SET ORDG=$PIECE(^TMP("ORUDQO",$JOB,ORINDEX),U,3)
+8 SET ORDISABL=$PIECE(^TMP("ORUDQO",$JOB,ORINDEX),U,4)
+9 WRITE !,$JUSTIFY(ORINDEX,5)_". "_ORQONAM,?60,ORDG,?70,ORDISABL
End DoDot:1
if $Y>ORPMAX
QUIT
+10 SET ORSTART=ORINDEX-ORPMAX
+11 QUIT
+12 ;
MOVE(ORQDLG) ;Move changes the DISPLAY GROUP to CLINIC MEDICATIONS or CLINIC INFUSIONS
+1 ;ORQDLG is the index from ^TMP("ORUDQO",$J,index)=order dialog ifn^order NAME(.01)^DisplayGroup^Disabled
+2 NEW ORIFN,ORCONVDG
SET ORIFN=$PIECE(^TMP("ORUDQO",$JOB,ORQDLG),U)
if $GET(ORIFN)=""
QUIT
+3 IF $DATA(^ORD(101.41,ORIFN,0))
Begin DoDot:1
+4 SET ORCONVDG=$PIECE(^TMP("ORUDQO",$JOB,ORQDLG),U,3)
+5 SET ORCONVDG=$SELECT(ORCONVDG="UDM":ORCMDG,1:ORCIDG)
+6 SET $PIECE(^ORD(101.41,ORIFN,0),U,5)=$GET(ORCONVDG)
+7 IF $DATA(^TMP("ORUDQO",$JOB,ORQDLG))
KILL ^TMP("ORUDQO",$JOB,ORQDLG)
End DoDot:1
QUIT
+8 IF '$TEST
Begin DoDot:1
+9 WRITE $CHAR(7),!,"Abort: Order dialog not found - check file entry and try again."
+10 WRITE !,"Order Dialog: "_$PIECE(^ORD(101.41,ORIFN,0),U)
End DoDot:1
+11 QUIT
COPY(ORQDLG) ;copy creates a new CLINIC MEDICATIONS or CLINIC INFUSIONS qo dialog and will ask to delete the original qo
+1 ;ORQDLG is the index from ^TMP("ORUDQO",$J,index)=order dialog ifn^order NAME(.01)^DisplayGroup^Disabled
+2 NEW ORQIFN,ORNUNAME,ORNUIFN,ORCUR0,ORESULT,ORPOINT,OR30350,ORTMPDLG,ORDIGP
+3 ;no delete if 350 not installed
SET OR30350=$$PATCH^XPDUTL("OR*3.0*350")
+4 SET ORQIFN=$PIECE(^TMP("ORUDQO",$JOB,ORQDLG),U)
if +$GET(ORQIFN)'>0
QUIT
+5 SET ORDIGP=$PIECE(^TMP("ORUDQO",$JOB,ORQDLG),U,3)
+6 SET ORDIGP=$SELECT(ORDIGP="UDM":ORCMDG,1:ORCIDG)
+7 if '$DATA(^ORD(101.41,ORQIFN,0))
QUIT
+8 SET ORNUNAME=$$GETNAME()
IF $GET(ORNUNAME)="^"
SET ORQDLG=ORNUNAME
QUIT
+9 SET ORNUIFN=$$STUB(101.41,ORNUNAME)
IF +$GET(ORNUIFN)'>0
WRITE !,"Error creating new entry. Please try again later."
QUIT
+10 NEW I,DA,DIE,DR,DIK,ORTEMP
+11 ;get 0 node of current QO
SET ORCUR0=^ORD(101.41,ORQIFN,0)
+12 FOR I=2,4,6,8,9
SET $PIECE(^ORD(101.41,ORNUIFN,0),U,I)=$PIECE(ORCUR0,U,I)
+13 SET $PIECE(^ORD(101.41,ORNUIFN,0),U,5)=$GET(ORDIGP)
+14 ;disp text
if $LENGTH($PIECE(ORCUR0,U,2))
SET ^ORD(101.41,"C",$$UP^XLFSTR($PIECE(ORCUR0,U,2)),ORNUIFN)=""
+15 FOR I=2,3,3.1,4,5,6,7,9,10
IF $DATA(^ORD(101.41,ORQIFN,I))
MERGE ^ORD(101.41,ORNUIFN,I)=^ORD(101.41,ORQIFN,I)
+16 IF $PIECE(ORCUR0,U,7)
SET ORTEMP=$PIECE(ORCUR0,U,7)
SET DA=ORNUIFN
SET DIE="^ORD(101.41,"
SET DR="7///^S X=ORTEMP;99///^S X=$H"
DO ^DIE
+17 KILL DA
SET DA(1)=ORNUIFN
SET DIK="^ORD(101.41,"_ORNUIFN_",10,"
SET DIK(1)="2^AD"
DO ENALL^DIK
+18 WRITE !!," Quick order copy complete."
+19 IF ($GET(OR30350)=1)
Begin DoDot:1
+20 IF '$$DELOK()
Begin DoDot:2
+21 WRITE !,"OK - If desired, you can manually delete the QO via the QO editor."
+22 SET ORQDLG="^"
DO CONT("using the conversion utility")
End DoDot:2
QUIT
+23 SET ORPOINT=$$PTRCHECK(ORQIFN)
IF +$GET(ORPOINT)>0
Begin DoDot:2
+24 SET ORQDLG="^"
DO CONT("using the conversion utility")
End DoDot:2
QUIT
+25 if $GET(ORQDLG)="^"
QUIT
+26 WRITE !,"Now deleting original quick order..."
+27 SET ORESULT=$$DELETE(ORQIFN)
+28 IF $GET(ORESULT)'="@"
WRITE !,"Error deleting IEN "_ORQIFN_" from ORDER DIALOG (101.41)."
+29 IF '$TEST
IF $DATA(^TMP("ORUDQO",$JOB,ORQDLG))
KILL ^TMP("ORUDQO",$JOB,ORQDLG)
End DoDot:1
QUIT
+30 QUIT
+31 ;
BLDUDQO ;build list of UDM and IVM qos
+1 NEW ORUDMDG,ORIVMED,ORDLGNM,ORIFN,ORINDEX,ORDISABL,ORDG
+2 SET ORINDEX=1
SET ORDLGNM=""
+3 SET ORUDMDG=$ORDER(^ORD(100.98,"B","UNIT DOSE MEDICATIONS",""))
+4 SET ORIVMED=$ORDER(^ORD(100.98,"B","IV MEDICATIONS",""))
+5 if $GET(ORUDMDG)=""!($GET(ORIVMED)="")
QUIT
+6 KILL ^TMP("ORUDQO",$JOB)
+7 FOR
SET ORDLGNM=$ORDER(^ORD(101.41,"B",ORDLGNM))
if $GET(ORDLGNM)=""
QUIT
Begin DoDot:1
+8 SET ORIFN=$ORDER(^ORD(101.41,"B",ORDLGNM,""))
+9 if +$GET(ORIFN)'>0
QUIT
+10 if $PIECE($GET(^ORD(101.41,ORIFN,0)),U,5)'=ORUDMDG&($PIECE($GET(^ORD(101.41,ORIFN,0)),U,5)'=ORIVMED)!($PIECE($GET(^ORD(101.41,ORIFN,0)),U,5)="")
QUIT
+11 if $PIECE($GET(^(0)),U,4)'="Q"
QUIT
+12 if $EXTRACT($PIECE($GET(^(0)),U),1,6)="ORWDQ "
QUIT
+13 SET ORDISABL=$PIECE($GET(^(0)),U,3)
+14 SET ORDG=$PIECE($GET(^(0)),U,5)
SET ORDG=$SELECT(ORDG=ORUDMDG:"UDM",ORDG=ORIVMED:"IVM",1:"")
+15 SET ORDISABL=$SELECT($LENGTH($GET(ORDISABL))>0:"YES",1:"")
+16 SET ^TMP("ORUDQO",$JOB,ORINDEX)=ORIFN_"^"_$PIECE(^ORD(101.41,ORIFN,0),U)_"^"_ORDG_"^"_ORDISABL
SET ORINDEX=ORINDEX+1
End DoDot:1
+17 QUIT
+18 ;
GETNAME() ;get new name for copied dialog
+1 ;prompt for new NAME .01
NEW DIR,X,Y
+2 SET DIR(0)="F^3:63^"
SET DIR("A")="NAME"
+3 SET DIR("?")="Enter a NAME (between 3 and 63 characters) for the new order dialog."
NM DO ^DIR
+1 IF $DATA(DIRUT)!($DATA(DUOUT))
SET Y="^"
QUIT Y
+2 IF $ORDER(^ORD(101.41,"AB",X,""))'=""
WRITE $CHAR(7),!,"Another entry already exists by this name!",!
SET X=""
GOTO NM
+3 if X[""""!($ASCII(X)=45)
KILL X
IF $DATA(X)
if $LENGTH(X)>63!($LENGTH(X)<3)!'(X'?1P.E)
KILL X
+4 IF '$DATA(X)
GOTO NM
+5 QUIT Y
PTRCHECK(ORIEN) ; check for pointers if Copy action
+1 NEW IHAZPTR
SET IHAZPTR=0
+2 IF $DATA(^ORD(101.41,"AD",ORIEN))
SET IHAZPTR=1
WRITE $CHAR(7),!,"Cannot delete order dialog - currently in use!",!
QUIT IHAZPTR
+3 SET IHAZPTR=$$PTRCHK^ORCMEDT4(ORIEN,"QO PTRS")
+4 IF IHAZPTR
Begin DoDot:1
+5 WRITE $CHAR(7),!,"Cannot delete order dialog - other file entries point to this order dialog!",!
+6 DO CONT("reviewing pointer report")
+7 DO PTRRPT^ORCMEDT4("QO PTRS",ORIEN)
End DoDot:1
+8 QUIT IHAZPTR
+9 ;
ACTASK() ; get action Move or Copy
+1 NEW DIR,X,Y
+2 SET DIR(0)="S^1:MOVE;2:COPY"
+3 SET DIR("?")="Choose an action for this quick order"
+4 SET DIR("?",1)="Move converts the selected QO into a new Clinic Medication QO."
+5 SET DIR("?",2)="Copy clones the selected QO into a new Clinic Medication QO."
+6 SET DIR("?",3)="The original QO is then deleted."
+7 DO ^DIR
+8 if $DATA(DTOUT)!($DATA(DUOUT))
SET Y="^"
+9 QUIT Y
+10 ;
DELETE(IFN) ;remove old QO;
+1 NEW Y,DA,DIK,IDX1,IDX2
SET (IDX1,Y)=0
+2 FOR
SET IDX1=$ORDER(^ORD(101.44,"C",IFN,IDX1))
if 'IDX1
QUIT
Begin DoDot:1
+3 SET IDX2=0
+4 FOR
SET IDX2=$ORDER(^ORD(101.44,"C",IFN,IDX1,IDX2))
if 'IDX2
QUIT
Begin DoDot:2
+5 SET DA=IDX2
SET DA(1)=IDX1
SET DIK="^ORD(101.44,"_IDX1_",10,"
DO ^DIK
End DoDot:2
End DoDot:1
+6 KILL DA
SET DA=IFN
SET DIK="^ORD(101.41,"
DO ^DIK
WRITE " ...deleted."
SET Y="@"
+7 QUIT Y
+8 ;
STUB(ORFILE,ORNAME) ; create new entry in file
+1 NEW FDA,MSG,IEN
+2 SET FDA(ORFILE,"+1,",.01)=ORNAME
+3 DO UPDATE^DIE("","FDA","IEN","MSG")
+4 IF $DATA(MSG)>0
+5 DO CLEAN^DILF
+6 QUIT IEN(1)
+7 ;
CONT(MSG) ; -- gives user a chance to read output from pointer check
+1 NEW X,Y,DIR
+2 SET DIR(0)="FO"
SET DIR("A")="Press any key to continue "_MSG
+3 SET DIR("?")="Enter any key to continue; enter ^ to exit."
+4 DO ^DIR
+5 QUIT
DELOK() ; -- Are you ready?
+1 NEW X,Y,DIR
+2 SET DIR(0)="YA"
SET DIR("A")="Do you want to delete the original quick order? "
SET DIR("B")="NO"
+3 WRITE !
DO ^DIR
+4 QUIT +Y
MOVOK() ; -- Are you ready?
+1 NEW X,Y,DIR
+2 SET DIR(0)="YA"
SET DIR("A")="Do you want to MOVE the selected quick order(s)? "
SET DIR("B")="NO"
+3 WRITE !
DO ^DIR
+4 QUIT +Y
+1 WRITE @IOF
+2 WRITE ".......Quick Order",$$REPEAT^XLFSTR(".",42),?60,"Type...",?67,"Disabled....."
+3 QUIT
