OREV4 ;SLC/DAN Event delayed orders cont ;08/03/15 15:25
;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,367,377**;Dec 17, 1997;Build 582
;DBIA reference section
;10006 - DIC
;10018 - DIE
;10013 - DIK
;10103 - XLFDT
;2056 - DIQ
;2263 - XPAR
;
N Y,DIC,ZTSAVE,IEN
S DIC="^ORE(100.2,",DIC(0)="AEMQ" D ^DIC
Q:Y=-1 ;Quit if no selection made
S IEN=+Y
W !
S ZTSAVE("IEN")="",ZTSAVE("DIC")="",ZTSAVE("IO*")=""
D QUE^ORUTL1("DQI^OREV4","Patient event inquiry",.ZTSAVE) ;Get device to print on
Q
;
DQI ;Tasked entry point or continue if not queued
U IO
S DA=IEN
D EN^DIQ
Q
;
CHKPRM ;Checks to see if event is defined in either the OREVNT DEFAULT
;or the OREVNT COMMON LIST parameter. If so, then it will be removed
;from the parameters as PARENT type events are not allowed in these
;parameters. This API is called when an event becomes a parent.
N DIC,Y,X,PRMC,PRMD,PARAM,I,J
S DIC=8989.51,DIC(0)="MX",X="OREVNT COMMON LIST" D ^DIC
Q:Y=-1 ;Parameter doesn't exist
S PRMC=+Y
S X="OREVNT DEFAULT" D ^DIC
Q:Y=-1 ;Parameter doesn't exist
S PRMD=+Y
F PARAM=PRMC,PRMD D
.K ORLST
.D ENVAL^XPAR(.ORLST,PRMC) ;get list of values
.Q:ORLST=0 ;No values
.S I="" F S I=$O(ORLST(I)) Q:I="" D
..S J="" F S J=$O(ORLST(I,J)) Q:J="" D
...I ORLST(I,J)=DA D EN^XPAR(I,PARAM,J,"@") ;delete event from parameter
Q
;
DELAYED(DFN) ;Display list of delayed events for a patient, identified by DFN
N EVT,IFN,DISP
I '$D(^ORE(100.2,"AE",DFN)) Q ;Quit if no delayed orders exist for the patient
S EVT=0,DISP=0
F S EVT=$O(^ORE(100.2,"AE",DFN,EVT)) Q:'+EVT D
.S IFN=$O(^ORE(100.2,"AE",DFN,EVT,0))
.Q:$$LAPSED^OREVNTX(IFN) ;quit if event has lapsed
.W:'DISP !!,"Delayed orders exist for this patient!",$C(7) S DISP=1
.W !,"EVENT: ",$P($G(^ORD(100.5,+$P(^ORE(100.2,IFN,0),U,2),0)),U,8),", created on ",$$FMTE^XLFDT($P(^ORE(100.2,IFN,0),U,5),1)
Q
;
PARENTOK() ;This function determines if the event can be a parent
;if an event has future delayed orders tied to it then it can't be
;a parent
N OK,SUB,RIEN,PIEN
S OK=1
S SUB="^ORE(100.2,""AE"")"
F S SUB=$Q(@SUB) Q:SUB'["AE"!('OK) D
.S RIEN=$P(SUB,",",4) ;Release event ID
.S PIEN=+$P(SUB,",",5) ;Patient event ID -- p.367 added "+" to prevent PIEN from containing ")"
.Q:$$LAPSED^OREVNTX(PIEN) ;quit if event has lapsed
.I RIEN=DA W !!,"You may not make ",$P($G(^ORD(100.5,DA,0)),U)," a parent",!,"at this time because there are unprocessed delayed orders assigned to it." H 3 S OK=0
Q OK
;
ACTSURG(ORTYPE,DA) ;Function returns 1 if an active surgery event already exists
N ACT,DIV,I
S ACT=0
I ORTYPE="E" D
.S DIV=$P($G(^ORD(100.5,DA,0)),U,3)
.S I=0 F S I=$O(^ORD(100.5,"ADT","O",I)) Q:'+I I DA'=I I DIV=$P($G(^ORD(100.5,I,0)),U,3)&('$G(^ORD(100.5,I,1))) S ACT=1
.Q
I ORTYPE="A" D
.S DIV=$P($G(^ORD(100.6,DA,0)),U,3)
.S I=0 F S I=$O(^ORD(100.6,"AE",DIV,"O",I)) Q:'+I I I'=DA S ACT=1
.Q
Q ACT
;
FROMTO(MUL,SUB1,SUB2) ;Check FROM - TO entries in file 100.6
N DA,DIK,LOC0,X,Y,DEL,ERR
I MUL="S" D Q
.I '$D(^ORD(100.6,SUB1,4,SUB2,1,"B")) D ;Check for TO entries in specialties multiple
..W !!,"ERROR - Missing TO entry - ",$P($G(^DIC(45.7,$P(^ORD(100.6,SUB1,4,SUB2,0),U),0)),U)," DELETED.",!
..S DA(1)=SUB1,DA=SUB2,DIK="^ORD(100.6,"_DA(1)_",4," D ^DIK
;
I MUL="L" D
.S LOC0=^ORD(100.6,SUB1,5,SUB2,0)
.I +$P(LOC0,U,2)=0&($P(LOC0,U,3)="") S DEL=1,ERR=1
.I +$P(LOC0,U,4)=0&($P(LOC0,U,5)="") S DEL=1,ERR=1
.I $G(ERR) W !!,"ERROR - Missing FROM or TO location - '",$P(LOC0,U),"' DELETED.",! Q
.I $P(LOC0,U,2) D CLEAR(SUB1,SUB2,2) ;If user selects "all" clear "from" field
.I $P(LOC0,U,4) D CLEAR(SUB1,SUB2,4) ;If user selects "all" clear "to" field
.I $P(LOC0,U,2)&($P(LOC0,U,4)) W !!,"WARNING - You've defined a 'FROM ALL' locations to 'TO ALL' locations entry",!,"and it will supercede all other entries.",! Q
.I $O(^ORD(100.6,SUB1,5,"ADC",$S($P(LOC0,U,2)=1:"ALL",1:$P(LOC0,U,3)),$S($P(LOC0,U,4)=1:"ALL",1:$P(LOC0,U,5)),SUB2)) S DEL=1,ERR=1
.I $O(^ORD(100.6,SUB1,5,"ADC",$S($P(LOC0,U,2)=1:"ALL",1:$P(LOC0,U,3)),$S($P(LOC0,U,4)=1:"ALL",1:$P(LOC0,U,5)),SUB2),-1) S DEL=1,ERR=1
.I $G(ERR) W !!,"ERROR - Duplicate entry exists - '",$P(LOC0,U),"' DELETED.",!
I $G(DEL) S DIK="^ORD(100.6,"_SUB1_",5,",DA=SUB2,DA(1)=SUB1 D ^DIK
Q
;
CLEAR(TENT,MENT,FIELD) ;Clear selected fields
N DA,DIE,Y,X,FILE
S FILE(100.62,MENT_","_TENT_",",FIELD)="@" D FILE^DIE("","FILE")
Q
;
EXCOI(IEN) ;
;
EXCOI1 ;
;Protect FileMan variables
W !,"EXCEPT ORDERABLE ITEMS"
N D,D0,DA,DC,DDES,DE,DG,DH,DI,DIC,DIDEL,DIE,DIEDA,DIEL,DIEN,DIR,DIETMP
N DIEXREF,DIFLD,DIEIENS,DINUSE,DIP,DISYS,DK,DL,DM,DP,DQ,DR,DU
;
N ADD,C,ARRAY,EXIT,DISPLAY,EDIT,EXCLUDE,HELP,IND,LIST,NAME,NODE,NUM,OI,OINODE,PROMPT,RESULT,SEQ,SARRAY,TEMP,VAL,X,Y
;find existing OI, capture ones that cannot be remove
S C=0,EXIT=""
S SEQ=0 F S SEQ=$O(^ORD(100.6,IEN,8,SEQ)) Q:SEQ'>0 D
.S NODE=$G(^ORD(100.6,IEN,8,SEQ,0)),OI=$P(NODE,U) Q:OI'>0
.S OINODE=$G(^ORD(101.43,OI,0))
.S NAME=$P(OINODE,U) Q:NAME="" Q:$P(OINODE,U,5)'>0
.S DISPLAY=$P($G(^ORD(100.98,$P(OINODE,U,5),0)),U) Q:DISPLAY=""
.I +$P(NODE,U,2)'=1 S EDIT(NAME,OI)=SEQ_U_DISPLAY Q
.S EXCLUDE(NAME,OI)=SEQ_U_DISPLAY
;
I '$D(EXCLUDE),'$D(EDIT) S ADD=$$ADD(IEN) G:ADD=1 EXCOI1 G:ADD=0 EXCOIX
S VAL="" I $D(EDIT) D
.S TEMP="S^A:New Orderablle Item to Exclude Orderable Item List;D:Delete exisitng Exclude Orderable Item;Q:Quit",PROMPT="Delete/Add'"
.S VAL=$$ASK(TEMP,PROMPT,1)
I VAL="Q" G EXCOIX
I VAL="A" D ADD(IEN) G EXCOI1
;
I $D(EXCLUDE) D
.W !,"Cannot remove the following orderable item(s):"
.S NAME="" F S NAME=$O(EXCLUDE(NAME)) Q:NAME="" D
..S OI=0 F S OI=$O(EXCLUDE(NAME,OI)) Q:OI'>0 W !," "_NAME_" ("_$P(EXCLUDE(NAME,OI),U,2)_")"
.H 1
;
I '$D(EDIT) S ADD=$$ADD(IEN) G:ADD=1 EXCOI1 G:ADD=0 EXCOIX
W !!,"Can delete the following orderable item(s):"
W !,"Deletion occurs immediately after selection"
S NAME="" F S NAME=$O(EDIT(NAME)) Q:NAME="" D
.S OI=0 F S OI=$O(EDIT(NAME,OI)) Q:OI'>0 D
..S NODE=$G(EDIT(NAME,OI)) S SEQ=$P(NODE,U) Q:SEQ'>0
..S C=C+1,ARRAY(C)=" "_$J(C,4)_" - "_NAME_" ("_$P(EDIT(NAME,OI),U,2)_")",SEQARRAY(C)=SEQ_U_OI_U_NAME_U_$P(EDIT(NAME,OI),U,2)
;
M DIR("A")=ARRAY
S DIR("A")="Select number to delete from 'Exclude Orderable Item List'"
S DIR(0)="LO^1:"_C
D ^DIR
S NUM=$L(Y,",")-1
I NUM=0 Q
S LIST=Y
F IND=1:1:NUM D
.S SEQ=$P(LIST,",",IND)
.S NODE=SEQARRAY(SEQ)
.D DELETE(IEN,NODE)
I EXIT=U G EXCOI1
;
EXCOIX ;
Q
;
ASK(TEMP,PROMPT,HELP) ;
N DIR,Y
S DIR(0)=TEMP
S DIR("A")=PROMPT
S DIR("??")=U_"D HELP^OREV4("_HELP_")"
D ^DIR
Q Y
;
ADD(IEN) ;
N ARRAY,PROMPT,TEMP,VAL
D LOOKUP(.ARRAY)
I '$D(ARRAY) Q 0
S VAL="" F S VAL=$O(ARRAY(VAL)) Q:VAL="" D
.N DA,DIC,X,Y
.S DA(1)=IEN,X=+VAL
.S DIC="^ORD(100.6,"_DA(1)_",8,",DIC(0)="L"
.D FILE^DICN
.I Y=-1 W !,"Error adding OI "_$P(VAL,U,2)_" to Auto-DC Rule" H 1
Q 1
;
DELETE(IEN,NODE) ;
W !,"Deleting Orderable Item: "_$P(NODE,U,3)
N DA,DIK
S DA(1)=IEN,DA=+NODE
S DIK="^ORD(100.6,"_DA(1)_",8,"
D ^DIK
Q
;
LOOKUP(ARRAY) ;
N DIC,DUOUT,QUIT,Y
S QUIT=0
F D Q:QUIT=1
.S DIC="^ORD(101.43,",DIC("S")="I '$G(^ORD(101.43,Y,.1))"
.S DIC("A")="Select Orderable Item: ",DIC(0)="ABE"
.D ^DIC
.I $G(DUOUT)!(Y=-1) S QUIT=1 Q
.S ARRAY(Y)=""
Q
;
HELP(HELP) ;
W !,"Select A to add Orderable Item(s) to the 'Exclude Orderble Item List'. Select D "
W !,"to delete Orderable Item(s) from the 'Exclude Orderable List'."
Q
;
FILESCR() ;
I $G(ORMGR)=1 Q 1
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HOREV4 7625 printed Oct 16, 2024@18:31:15 Page 2
OREV4 ;SLC/DAN Event delayed orders cont ;08/03/15 15:25
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,367,377**;Dec 17, 1997;Build 582
+2 ;DBIA reference section
+3 ;10006 - DIC
+4 ;10018 - DIE
+5 ;10013 - DIK
+6 ;10103 - XLFDT
+7 ;2056 - DIQ
+8 ;2263 - XPAR
+9 ;
+10 NEW Y,DIC,ZTSAVE,IEN
+11 SET DIC="^ORE(100.2,"
SET DIC(0)="AEMQ"
DO ^DIC
+12 ;Quit if no selection made
if Y=-1
QUIT
+13 SET IEN=+Y
+14 WRITE !
+15 SET ZTSAVE("IEN")=""
SET ZTSAVE("DIC")=""
SET ZTSAVE("IO*")=""
+16 ;Get device to print on
DO QUE^ORUTL1("DQI^OREV4","Patient event inquiry",.ZTSAVE)
+17 QUIT
+18 ;
DQI ;Tasked entry point or continue if not queued
+1 USE IO
+2 SET DA=IEN
+3 DO EN^DIQ
+4 QUIT
+5 ;
CHKPRM ;Checks to see if event is defined in either the OREVNT DEFAULT
+1 ;or the OREVNT COMMON LIST parameter. If so, then it will be removed
+2 ;from the parameters as PARENT type events are not allowed in these
+3 ;parameters. This API is called when an event becomes a parent.
+4 NEW DIC,Y,X,PRMC,PRMD,PARAM,I,J
+5 SET DIC=8989.51
SET DIC(0)="MX"
SET X="OREVNT COMMON LIST"
DO ^DIC
+6 ;Parameter doesn't exist
if Y=-1
QUIT
+7 SET PRMC=+Y
+8 SET X="OREVNT DEFAULT"
DO ^DIC
+9 ;Parameter doesn't exist
if Y=-1
QUIT
+10 SET PRMD=+Y
+11 FOR PARAM=PRMC,PRMD
Begin DoDot:1
+12 KILL ORLST
+13 ;get list of values
DO ENVAL^XPAR(.ORLST,PRMC)
+14 ;No values
if ORLST=0
QUIT
+15 SET I=""
FOR
SET I=$ORDER(ORLST(I))
if I=""
QUIT
Begin DoDot:2
+16 SET J=""
FOR
SET J=$ORDER(ORLST(I,J))
if J=""
QUIT
Begin DoDot:3
+17 ;delete event from parameter
IF ORLST(I,J)=DA
DO EN^XPAR(I,PARAM,J,"@")
End DoDot:3
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
DELAYED(DFN) ;Display list of delayed events for a patient, identified by DFN
+1 NEW EVT,IFN,DISP
+2 ;Quit if no delayed orders exist for the patient
IF '$DATA(^ORE(100.2,"AE",DFN))
QUIT
+3 SET EVT=0
SET DISP=0
+4 FOR
SET EVT=$ORDER(^ORE(100.2,"AE",DFN,EVT))
if '+EVT
QUIT
Begin DoDot:1
+5 SET IFN=$ORDER(^ORE(100.2,"AE",DFN,EVT,0))
+6 ;quit if event has lapsed
if $$LAPSED^OREVNTX(IFN)
QUIT
+7 if 'DISP
WRITE !!,"Delayed orders exist for this patient!",$CHAR(7)
SET DISP=1
+8 WRITE !,"EVENT: ",$PIECE($GET(^ORD(100.5,+$PIECE(^ORE(100.2,IFN,0),U,2),0)),U,8),", created on ",$$FMTE^XLFDT($PIECE(^ORE(100.2,IFN,0),U,5),1)
End DoDot:1
+9 QUIT
+10 ;
PARENTOK() ;This function determines if the event can be a parent
+1 ;if an event has future delayed orders tied to it then it can't be
+2 ;a parent
+3 NEW OK,SUB,RIEN,PIEN
+4 SET OK=1
+5 SET SUB="^ORE(100.2,""AE"")"
+6 FOR
SET SUB=$QUERY(@SUB)
if SUB'["AE"!('OK)
QUIT
Begin DoDot:1
+7 ;Release event ID
SET RIEN=$PIECE(SUB,",",4)
+8 ;Patient event ID -- p.367 added "+" to prevent PIEN from containing ")"
SET PIEN=+$PIECE(SUB,",",5)
+9 ;quit if event has lapsed
if $$LAPSED^OREVNTX(PIEN)
QUIT
+10 IF RIEN=DA
WRITE !!,"You may not make ",$PIECE($GET(^ORD(100.5,DA,0)),U)," a parent",!,"at this time because there are unprocessed delayed orders assigned to it."
HANG 3
SET OK=0
End DoDot:1
+11 QUIT OK
+12 ;
ACTSURG(ORTYPE,DA) ;Function returns 1 if an active surgery event already exists
+1 NEW ACT,DIV,I
+2 SET ACT=0
+3 IF ORTYPE="E"
Begin DoDot:1
+4 SET DIV=$PIECE($GET(^ORD(100.5,DA,0)),U,3)
+5 SET I=0
FOR
SET I=$ORDER(^ORD(100.5,"ADT","O",I))
if '+I
QUIT
IF DA'=I
IF DIV=$PIECE($GET(^ORD(100.5,I,0)),U,3)&('$GET(^ORD(100.5,I,1)))
SET ACT=1
+6 QUIT
End DoDot:1
+7 IF ORTYPE="A"
Begin DoDot:1
+8 SET DIV=$PIECE($GET(^ORD(100.6,DA,0)),U,3)
+9 SET I=0
FOR
SET I=$ORDER(^ORD(100.6,"AE",DIV,"O",I))
if '+I
QUIT
IF I'=DA
SET ACT=1
+10 QUIT
End DoDot:1
+11 QUIT ACT
+12 ;
FROMTO(MUL,SUB1,SUB2) ;Check FROM - TO entries in file 100.6
+1 NEW DA,DIK,LOC0,X,Y,DEL,ERR
+2 IF MUL="S"
Begin DoDot:1
+3 ;Check for TO entries in specialties multiple
IF '$DATA(^ORD(100.6,SUB1,4,SUB2,1,"B"))
Begin DoDot:2
+4 WRITE !!,"ERROR - Missing TO entry - ",$PIECE($GET(^DIC(45.7,$PIECE(^ORD(100.6,SUB1,4,SUB2,0),U),0)),U)," DELETED.",!
+5 SET DA(1)=SUB1
SET DA=SUB2
SET DIK="^ORD(100.6,"_DA(1)_",4,"
DO ^DIK
End DoDot:2
End DoDot:1
QUIT
+6 ;
+7 IF MUL="L"
Begin DoDot:1
+8 SET LOC0=^ORD(100.6,SUB1,5,SUB2,0)
+9 IF +$PIECE(LOC0,U,2)=0&($PIECE(LOC0,U,3)="")
SET DEL=1
SET ERR=1
+10 IF +$PIECE(LOC0,U,4)=0&($PIECE(LOC0,U,5)="")
SET DEL=1
SET ERR=1
+11 IF $GET(ERR)
WRITE !!,"ERROR - Missing FROM or TO location - '",$PIECE(LOC0,U),"' DELETED.",!
QUIT
+12 ;If user selects "all" clear "from" field
IF $PIECE(LOC0,U,2)
DO CLEAR(SUB1,SUB2,2)
+13 ;If user selects "all" clear "to" field
IF $PIECE(LOC0,U,4)
DO CLEAR(SUB1,SUB2,4)
+14 IF $PIECE(LOC0,U,2)&($PIECE(LOC0,U,4))
WRITE !!,"WARNING - You've defined a 'FROM ALL' locations to 'TO ALL' locations entry",!,"and it will supercede all other entries.",!
QUIT
+15 IF $ORDER(^ORD(100.6,SUB1,5,"ADC",$SELECT($PIECE(LOC0,U,2)=1:"ALL",1:$PIECE(LOC0,U,3)),$SELECT($PIECE(LOC0,U,4)=1:"ALL",1:$PIECE(LOC0,U,5)),SUB2))
SET DEL=1
SET ERR=1
+16 IF $ORDER(^ORD(100.6,SUB1,5,"ADC",$SELECT($PIECE(LOC0,U,2)=1:"ALL",1:$PIECE(LOC0,U,3)),$SELECT($PIECE(LOC0,U,4)=1:"ALL",1:$PIECE(LOC0,U,5)),SUB2),-1)
SET DEL=1
SET ERR=1
+17 IF $GET(ERR)
WRITE !!,"ERROR - Duplicate entry exists - '",$PIECE(LOC0,U),"' DELETED.",!
End DoDot:1
+18 IF $GET(DEL)
SET DIK="^ORD(100.6,"_SUB1_",5,"
SET DA=SUB2
SET DA(1)=SUB1
DO ^DIK
+19 QUIT
+20 ;
CLEAR(TENT,MENT,FIELD) ;Clear selected fields
+1 NEW DA,DIE,Y,X,FILE
+2 SET FILE(100.62,MENT_","_TENT_",",FIELD)="@"
DO FILE^DIE("","FILE")
+3 QUIT
+4 ;
EXCOI(IEN) ;
+1 ;
EXCOI1 ;
+1 ;Protect FileMan variables
+2 WRITE !,"EXCEPT ORDERABLE ITEMS"
+3 NEW D,D0,DA,DC,DDES,DE,DG,DH,DI,DIC,DIDEL,DIE,DIEDA,DIEL,DIEN,DIR,DIETMP
+4 NEW DIEXREF,DIFLD,DIEIENS,DINUSE,DIP,DISYS,DK,DL,DM,DP,DQ,DR,DU
+5 ;
+6 NEW ADD,C,ARRAY,EXIT,DISPLAY,EDIT,EXCLUDE,HELP,IND,LIST,NAME,NODE,NUM,OI,OINODE,PROMPT,RESULT,SEQ,SARRAY,TEMP,VAL,X,Y
+7 ;find existing OI, capture ones that cannot be remove
+8 SET C=0
SET EXIT=""
+9 SET SEQ=0
FOR
SET SEQ=$ORDER(^ORD(100.6,IEN,8,SEQ))
if SEQ'>0
QUIT
Begin DoDot:1
+10 SET NODE=$GET(^ORD(100.6,IEN,8,SEQ,0))
SET OI=$PIECE(NODE,U)
if OI'>0
QUIT
+11 SET OINODE=$GET(^ORD(101.43,OI,0))
+12 SET NAME=$PIECE(OINODE,U)
if NAME=""
QUIT
if $PIECE(OINODE,U,5)'>0
QUIT
+13 SET DISPLAY=$PIECE($GET(^ORD(100.98,$PIECE(OINODE,U,5),0)),U)
if DISPLAY=""
QUIT
+14 IF +$PIECE(NODE,U,2)'=1
SET EDIT(NAME,OI)=SEQ_U_DISPLAY
QUIT
+15 SET EXCLUDE(NAME,OI)=SEQ_U_DISPLAY
End DoDot:1
+16 ;
+17 IF '$DATA(EXCLUDE)
IF '$DATA(EDIT)
SET ADD=$$ADD(IEN)
if ADD=1
GOTO EXCOI1
if ADD=0
GOTO EXCOIX
+18 SET VAL=""
IF $DATA(EDIT)
Begin DoDot:1
+19 SET TEMP="S^A:New Orderablle Item to Exclude Orderable Item List;D:Delete exisitng Exclude Orderable Item;Q:Quit"
SET PROMPT="Delete/Add'"
+20 SET VAL=$$ASK(TEMP,PROMPT,1)
End DoDot:1
+21 IF VAL="Q"
GOTO EXCOIX
+22 IF VAL="A"
DO ADD(IEN)
GOTO EXCOI1
+23 ;
+24 IF $DATA(EXCLUDE)
Begin DoDot:1
+25 WRITE !,"Cannot remove the following orderable item(s):"
+26 SET NAME=""
FOR
SET NAME=$ORDER(EXCLUDE(NAME))
if NAME=""
QUIT
Begin DoDot:2
+27 SET OI=0
FOR
SET OI=$ORDER(EXCLUDE(NAME,OI))
if OI'>0
QUIT
WRITE !," "_NAME_" ("_$PIECE(EXCLUDE(NAME,OI),U,2)_")"
End DoDot:2
+28 HANG 1
End DoDot:1
+29 ;
+30 IF '$DATA(EDIT)
SET ADD=$$ADD(IEN)
if ADD=1
GOTO EXCOI1
if ADD=0
GOTO EXCOIX
+31 WRITE !!,"Can delete the following orderable item(s):"
+32 WRITE !,"Deletion occurs immediately after selection"
+33 SET NAME=""
FOR
SET NAME=$ORDER(EDIT(NAME))
if NAME=""
QUIT
Begin DoDot:1
+34 SET OI=0
FOR
SET OI=$ORDER(EDIT(NAME,OI))
if OI'>0
QUIT
Begin DoDot:2
+35 SET NODE=$GET(EDIT(NAME,OI))
SET SEQ=$PIECE(NODE,U)
if SEQ'>0
QUIT
+36 SET C=C+1
SET ARRAY(C)=" "_$JUSTIFY(C,4)_" - "_NAME_" ("_$PIECE(EDIT(NAME,OI),U,2)_")"
SET SEQARRAY(C)=SEQ_U_OI_U_NAME_U_$PIECE(EDIT(NAME,OI),U,2)
End DoDot:2
End DoDot:1
+37 ;
+38 MERGE DIR("A")=ARRAY
+39 SET DIR("A")="Select number to delete from 'Exclude Orderable Item List'"
+40 SET DIR(0)="LO^1:"_C
+41 DO ^DIR
+42 SET NUM=$LENGTH(Y,",")-1
+43 IF NUM=0
QUIT
+44 SET LIST=Y
+45 FOR IND=1:1:NUM
Begin DoDot:1
+46 SET SEQ=$PIECE(LIST,",",IND)
+47 SET NODE=SEQARRAY(SEQ)
+48 DO DELETE(IEN,NODE)
End DoDot:1
+49 IF EXIT=U
GOTO EXCOI1
+50 ;
EXCOIX ;
+1 QUIT
+2 ;
ASK(TEMP,PROMPT,HELP) ;
+1 NEW DIR,Y
+2 SET DIR(0)=TEMP
+3 SET DIR("A")=PROMPT
+4 SET DIR("??")=U_"D HELP^OREV4("_HELP_")"
+5 DO ^DIR
+6 QUIT Y
+7 ;
ADD(IEN) ;
+1 NEW ARRAY,PROMPT,TEMP,VAL
+2 DO LOOKUP(.ARRAY)
+3 IF '$DATA(ARRAY)
QUIT 0
+4 SET VAL=""
FOR
SET VAL=$ORDER(ARRAY(VAL))
if VAL=""
QUIT
Begin DoDot:1
+5 NEW DA,DIC,X,Y
+6 SET DA(1)=IEN
SET X=+VAL
+7 SET DIC="^ORD(100.6,"_DA(1)_",8,"
SET DIC(0)="L"
+8 DO FILE^DICN
+9 IF Y=-1
WRITE !,"Error adding OI "_$PIECE(VAL,U,2)_" to Auto-DC Rule"
HANG 1
End DoDot:1
+10 QUIT 1
+11 ;
DELETE(IEN,NODE) ;
+1 WRITE !,"Deleting Orderable Item: "_$PIECE(NODE,U,3)
+2 NEW DA,DIK
+3 SET DA(1)=IEN
SET DA=+NODE
+4 SET DIK="^ORD(100.6,"_DA(1)_",8,"
+5 DO ^DIK
+6 QUIT
+7 ;
LOOKUP(ARRAY) ;
+1 NEW DIC,DUOUT,QUIT,Y
+2 SET QUIT=0
+3 FOR
Begin DoDot:1
+4 SET DIC="^ORD(101.43,"
SET DIC("S")="I '$G(^ORD(101.43,Y,.1))"
+5 SET DIC("A")="Select Orderable Item: "
SET DIC(0)="ABE"
+6 DO ^DIC
+7 IF $GET(DUOUT)!(Y=-1)
SET QUIT=1
QUIT
+8 SET ARRAY(Y)=""
End DoDot:1
if QUIT=1
QUIT
+9 QUIT
+10 ;
HELP(HELP) ;
+1 WRITE !,"Select A to add Orderable Item(s) to the 'Exclude Orderble Item List'. Select D "
+2 WRITE !,"to delete Orderable Item(s) from the 'Exclude Orderable List'."
+3 QUIT
+4 ;
FILESCR() ;
+1 IF $GET(ORMGR)=1
QUIT 1
+2 QUIT 0
