- 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 Feb 18, 2025@23:57:14 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