OREV1 ;SLC/DAN Event delayed orders set up continued ;1/14/03 11:54
;;3.0;ORDER ENTRY/RESULTS REPORTING;**142,141,165**;Dec 17, 1997
;DBIA reference section
;2686 - ^XTV(8989.5 and ^XTV(8989.51
;519 - ^DIC(45.7
;2263 - XPAR
;10039- ^DIC(42
;10009- DICN
;10018- DIE
;10026- DIR
;10116- VALM1
;10103- XLFDT
SCR ;Sets DIC("S") for MAS MOVEMENT TYPE field of either file
N FILE
S FILE="^ORD("_$O(DR(1,0))_","
S DIC("S")="S TMP=$P("_FILE_"DA,0),U,2),TTP=$E($P(^DG(405.3,$P(^DG(405.2,Y,0),U,2),0),U)) I $S(TMP=TTP:1,1:0)"_$S('$G(@(FILE_DA_",1)")):"&('$$INUSEDC^OREV1())",1:"")
Q
;
ACT ;Inactivate or reactivate an event or auto dc rule
N ORJ,Y,ORTMP,DA,DIC,ORGLOB
S VALMBCK="R" D FULL^VALM1
S ORGLOB="^ORD(100."_$S(ORTYPE="E":"5,",1:"6,")
I $G(ORNMBR)="" S ORNMBR=$$ORDERS("activate/inactivate")
F ORJ=1:1:$L(ORNMBR,",")-1 S ORTMP=$P(ORNMBR,",",ORJ),DA=$O(^TMP("OREDO",$J,"IDX",ORTMP,0)) D FLIP(DA)
Q
;
FLIP(DA) ;Check status and flip if necessary
N STAT,DIR,DIE,DR,Y,NAME,CDT,MULT,IEN,SUB,USED,EVNTYPE
S NAME=$P(@(ORGLOB_DA_",0)"),U),EVNTYPE=$P(^(0),U,2)
S CDT=$$NOW^XLFDT
S STAT=$S($G(@(ORGLOB_DA_",1)")):^(1),1:0) ;Status is date/time if already inactivated
W !!,NAME," is currently ",$S(STAT:"IN",1:"")_"ACTIVE."
I ORTYPE="E",$$RELEVNTS(DA),'STAT W !!,"There are delayed orders awaiting release that are associated with this event.",!,"This event, even if inactivated, will still be applied to these delayed orders.",!!
I ORTYPE="A",'STAT W !!,"Inactivating auto-dc rules takes effect immediately.",!
I STAT,$G(EVNTYPE)="O",$$ACTSURG^OREV4(ORTYPE,DA) D Q
.W !,NAME,!,"can not be activated because you already have an active surgery rule for this",!,"division. Only one active surgery rule per division is allowed.",!
.S DIR(0)="E",DIR("A")="Press enter to continue" D ^DIR K DIR
I STAT,ORTYPE="E",$P($G(^ORD(100.5,DA,0)),U,12),$G(^ORD(100.5,$P(^(0),U,12),1)) D Q ;If inactive child event and parent is inactive don't activate child
.W !,NAME,!,"can not be activated until its parent event is active.",!
.S DIR(0)="E",DIR("A")="Press enter to continue" D ^DIR K DIR
I STAT,ORTYPE="E",'$$CANACT(DA,.USED) D Q
.W !,NAME,!,"can not be activated because the following locations",!,"and/or treating specialties are currently in use by other entries.",!
.F MULT="LOC","TS" W:$D(USED(MULT)) !,$S(MULT="LOC":"LOCATIONS:",1:"TREATING SPECIALTIES:"),! D
..S IEN=0 F S IEN=$O(USED(MULT,IEN)) Q:'+IEN D
...S SUB=0 F S SUB=$O(USED(MULT,IEN,SUB)) Q:'+SUB D
....W !,$S(MULT="LOC":$P($G(^DIC(42,SUB,0)),"^"),1:$P($G(^DIC(45.7,SUB,0)),"^"))," is in use by ",$P($G(@(ORGLOB_IEN_",0)")),"^"),!
.W !,"For active entries, LOCATIONS and TREATING SPECIALTIES",!,"must be unique within division and event type."
.S DIR(0)="E",DIR("A")="Press enter to continue" D ^DIR K DIR
I STAT I ORTYPE="A" I '$$CANACT(DA,.USED) D Q
.W !,NAME,!,"can not be activated because the following MAS movements",!,"are currently in use by other entries.",!
.S IEN=0 F S IEN=$O(USED(IEN)) Q:'+IEN D
..S SUB=0 F S SUB=$O(USED(IEN,SUB)) Q:'+SUB D
...W !,$P($G(^DG(405.2,IEN,0)),U)," is in use by ",$P($G(^ORD(100.6,SUB,0)),U)
.W !,"For active entries, MAS movements within DIVISION must be unique."
.S DIR(0)="E",DIR("A")="Press return to continue" D ^DIR K DIR
;
S DIR(0)="Y",DIR("B")="NO",DIR("A")="Are you sure you want to "_$S(STAT:"",1:"IN")_"ACTIVATE this entry" D ^DIR
I Y'=1 W !,"Nothing changed!" Q
S DIE=ORGLOB,DR="1///"_$S(STAT:"@",1:CDT) D ^DIE W !,NAME," is now "_$S(STAT:"",1:"IN")_"ACTIVATED!"
I 'STAT S DA(1)=DA,DA=$O(@(ORGLOB_DA(1)_",2,"_"""ACT"""_",0)")),DIE=ORGLOB_DA(1)_",2,",DR="1///"_CDT D ^DIE D:ORTYPE="E" UPDTCHLD^OREV3(DA(1),CDT) Q
D SET(DA,CDT)
Q
;
SET(MIEN,X) ;add new multiple to activation history
N DIC,DA
S DA(1)=MIEN
S DIC=ORGLOB_DA(1)_",2,",DIC(0)="L"
D FILE^DICN
Q
;
INUSE(MULT) ;determine if location or treating specialty is already in use
N ACTIVE,USED,NAME,TYPE,DIV,FMIEN
S USED=0,NAME="",FMIEN=$G(DA(1),DA)
S TYPE=$P($G(^ORD(100.5,FMIEN,0)),"^",2) ;movement type of entry being checked
S DIV=$P($G(^ORD(100.5,FMIEN,0)),"^",3) ;division of entry being checked
F S NAME=$O(^ORD(100.5,"C",NAME)) Q:NAME=""!(USED) D
.S ACTIVE=0 F S ACTIVE=$O(^ORD(100.5,"C",NAME,ACTIVE)) Q:'+ACTIVE!USED D
..Q:DIV'=$P($G(^ORD(100.5,ACTIVE,0)),"^",3) ;stop processing if not same division
..Q:TYPE'=$P($G(^ORD(100.5,ACTIVE,0)),"^",2) ;stop processing if not the same type
..S USED=$D(^ORD(100.5,ACTIVE,MULT,"B",Y)) I USED S WHO=ACTIVE
Q USED
;
CANACT(DA,USED) ;Function returns whether or not an entry can be activated.
;For EVENTS, locations and specialties must be unique within division
;and EVENT TYPE. For AUTO DC, movement types must be unique within
;division.
N MULT,SUB,Y,CANACT,WHO
S CANACT=1
I ORTYPE="E" F MULT="LOC","TS" D
.S SUB=0 F S SUB=$O(^ORD(100.5,DA,MULT,SUB)) Q:'+SUB D
..S Y=$G(^(SUB,0)) I Y I $$INUSE(MULT) S CANACT=0,USED(MULT,WHO,Y)=""
;
I ORTYPE="A" D
.S SUB=0 F S SUB=$O(^ORD(100.6,DA,3,SUB)) Q:'+SUB D
..S Y=+$G(^(SUB,0)) I Y I $$INUSEDC() S CANACT=0,USED(Y,WHO)=""
Q CANACT
;
INUSEDC() ;Checks AUTO-DC rules for unique movement types
N DIV,USED
S USED=0
S DIV=+$P($G(^ORD(100.6,DA,0)),U,3)
I DIV I $D(^ORD(100.6,"AC",DIV,Y)) S WHO=$O(^(Y,0)),USED=1
Q USED
;
HASREQD() ;Function returns whether entry has required entries or not
N REQD
S REQD=0
I ORTYPE="E" D
.I "^22^23^24^"[("^"_$P($G(^ORD(100.5,DA,0)),U,7)_"^") S REQD=1 Q ;From pass (transfer) doesn't require treating specialty
.I $O(^ORD(100.5,DA,"LOC",0))>0!($O(^ORD(100.5,DA,"TS",0))>0) S REQD=1 ;Has locations or treating specialties
.I $O(^ORD(100.5,DA,"LOC",0))>0&($O(^ORD(100.5,DA,"TS",0))>0) S REQD=2 ;Warn user that both must be true if both defined.
I ORTYPE="A" D
.I $P($G(^ORD(100.6,DA,0)),U,2)="O" S REQD=1 ;If type is operating room then movements not required
.I $P($G(^ORD(100.6,DA,0)),U,2)'="O"&($O(^ORD(100.6,DA,3,0))>0) S REQD=1 ;movement type exists
.I $P($G(^ORD(100.6,DA,0)),U,2)="T",$D(^ORD(100.6,DA,3,"B",4)),$P($G(^ORD(100.6,DA,3,0)),U,4)>1 S REQD=2 ;If transfer type and interward transfer type not by itself
Q REQD
;
CHKTYP(IEN) ;Check type of event and delete fields that are no longer needed based on the event type
N J,DR,DIE,DA,DIC,TYPE
I ORTYPE="E" D Q
.S TYPE=$P(^ORD(100.5,IEN,0),U,2)
.I TYPE'="A"&(TYPE'="T") D DELMUL(100.5,IEN,"""LOC"""),DELMUL(100.5,IEN,"""TS""") ;if not admit or transfer delete locations and treating specialties
.S DA=IEN,DIE=100.5,DR="7///@" D ^DIE ;Delete MAS MOVEMENT when type changes as movement types are associated with event type
;If not event type must be auto-dc
S TYPE=$P(^ORD(100.6,IEN,0),U,2)
I TYPE'="D" S DA=IEN,DIE=100.6,DR="6///@" D ^DIE ;Delete 'except from observation" if not discharge type
D DELMUL(100.6,IEN,3) ;delete MAS MOVEMENT
I TYPE'="S" D DELMUL(100.6,IEN,4) ;If not specialty type delete excluded treating specialties
I TYPE'="T" D DELMUL(100.6,IEN,5),DELMUL(100.6,IEN,6) ;If not transfer type delete included locations and included divisions
Q
;
ORDERS(ACTION) ; -- Return order numbers to act on, if action chosen first
N X,Y,DIR,MAX
S MAX=$G(VALMCNT) Q:MAX'>0 ""
I ACTION="edit" W !!,"Enter item number to edit or press enter to create a new entry"
S DIR(0)="LAO^1:"_MAX,DIR("A")="Select item(s): "
S DIR("?")="Enter the items you wish to "_ACTION_", as a range or list of numbers."_$S(ACTION="edit":" Press enter to create a NEW entry",1:"")
D ^DIR S:$D(DTOUT) Y="^"
I $D(Y(1)) W !,">>>Too many entries selected, try using smaller ranges" H 2 S Y="^"
Q Y
;
;
CANDEL(FILE) ;Determines if event or rule can be deleted
N DEL,EVENT,LIST,I,J
S DEL=1
S EVENT=$O(^XTV(8989.51,"B","ORWDX WRITE ORDERS EVENT LIST",0))
S LIST=$O(^XTV(8989.51,"B","OREVNT COMMON LIST",0))
I FILE=100.5 D
.I $O(^ORE(100.2,"E",DA,0)) W !,"< Can't delete this event because file 100.2 is pointing to it > " S DEL=0 Q
.I $D(^ORD(100.5,"DAD",DA)) W !,"< Can't delete parent events that have children > " S DEL=0 Q
.S FND=0
.K LST D ENVAL^XPAR(.LST,LIST)
.S I="" F S I=$O(LST(I)) Q:I=""!(FND) D
..S J="" F S J=$O(LST(I,J)) Q:J=""!(FND) I LST(I,J)=DA S FND=1
.I 'FND K LST D ENVAL^XPAR(.LST,EVENT) D
..S I="" F S I=$O(LST(I)) Q:I=""!(FND) D
...S J="" F S J=$O(LST(I,J)) Q:J=""!(FND) I DA=J S FND=1
.I FND W !,"< Can't delete event because parameters are pointing to it > " S DEL=0
;
I FILE=100.6 D
.I $O(^ORE(100.2,"DC",DA,0)) S DEL=0 W !,"< Can't delete this rule because file 100.2 is pointing to it > " Q
;
Q 'DEL ;Reverse value of DEL so that $T is set correctly for fileman to determine if entry can be deleted. Code is in ^DD(file#,.01,"DEL",.01,0)
;
ASKOBS() ;Function to determine if 'except from observation' field should be asked.
N ANS
S ANS=1
I ETYPE="D" I $D(^ORD(100.6,DA,3,"B",12))!($D(^ORD(100.6,DA,3,"B",38))) S ANS=0 ;Don't ask if MAS MOVEMENT TYPE is 12 (death) or 38 (death with autopsy)
I ETYPE="T" I '$D(^ORD(100.6,DA,3,"B",14)) S ANS=0 ;If MAS MOVEMENT TYPE doesn't contain FROM ASIH (VAH) when type is transfer then don't ask
Q ANS
;
DELMUL(FILE,IEN,LOC) ;Delete multiple entries for entry IEN in file FILE stored at location LOC
N I,DR,DIE,DA,DIC,GLOB,Y,DQ,DP,DL,DM,DI,DK
S GLOB="^ORD("_FILE_","_IEN_","
S I=0 F S I=$O(@(GLOB_LOC_","_I_")")) Q:'+I S DA(1)=IEN,DA=I,DR=".01///@",DIE="^ORD("_FILE_",DA(1),"_LOC_"," D ^DIE
Q
;
RELEVNTS(DA) ;Check to see if release event is currently being pointed to
N DFN,EVENT
S (DFN,EVENT)=0
F S DFN=$O(^ORE(100.2,"AE",DFN)) Q:'+DFN I $D(^ORE(100.2,"AE",DFN,DA)) S EVENT=1 Q
Q EVENT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HOREV1 9745 printed Sep 23, 2025@20:06:57 Page 2
OREV1 ;SLC/DAN Event delayed orders set up continued ;1/14/03 11:54
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**142,141,165**;Dec 17, 1997
+2 ;DBIA reference section
+3 ;2686 - ^XTV(8989.5 and ^XTV(8989.51
+4 ;519 - ^DIC(45.7
+5 ;2263 - XPAR
+6 ;10039- ^DIC(42
+7 ;10009- DICN
+8 ;10018- DIE
+9 ;10026- DIR
+10 ;10116- VALM1
+11 ;10103- XLFDT
SCR ;Sets DIC("S") for MAS MOVEMENT TYPE field of either file
+1 NEW FILE
+2 SET FILE="^ORD("_$ORDER(DR(1,0))_","
+3 SET DIC("S")="S TMP=$P("_FILE_"DA,0),U,2),TTP=$E($P(^DG(405.3,$P(^DG(405.2,Y,0),U,2),0),U)) I $S(TMP=TTP:1,1:0)"_$SELECT('$GET(@(FILE_DA_",1)")):"&('$$INUSEDC^OREV1())",1:"")
+4 QUIT
+5 ;
ACT ;Inactivate or reactivate an event or auto dc rule
+1 NEW ORJ,Y,ORTMP,DA,DIC,ORGLOB
+2 SET VALMBCK="R"
DO FULL^VALM1
+3 SET ORGLOB="^ORD(100."_$SELECT(ORTYPE="E":"5,",1:"6,")
+4 IF $GET(ORNMBR)=""
SET ORNMBR=$$ORDERS("activate/inactivate")
+5 FOR ORJ=1:1:$LENGTH(ORNMBR,",")-1
SET ORTMP=$PIECE(ORNMBR,",",ORJ)
SET DA=$ORDER(^TMP("OREDO",$JOB,"IDX",ORTMP,0))
DO FLIP(DA)
+6 QUIT
+7 ;
FLIP(DA) ;Check status and flip if necessary
+1 NEW STAT,DIR,DIE,DR,Y,NAME,CDT,MULT,IEN,SUB,USED,EVNTYPE
+2 SET NAME=$PIECE(@(ORGLOB_DA_",0)"),U)
SET EVNTYPE=$PIECE(^(0),U,2)
+3 SET CDT=$$NOW^XLFDT
+4 ;Status is date/time if already inactivated
SET STAT=$SELECT($GET(@(ORGLOB_DA_",1)")):^(1),1:0)
+5 WRITE !!,NAME," is currently ",$SELECT(STAT:"IN",1:"")_"ACTIVE."
+6 IF ORTYPE="E"
IF $$RELEVNTS(DA)
IF 'STAT
WRITE !!,"There are delayed orders awaiting release that are associated with this event.",!,"This event, even if inactivated, will still be applied to these delayed orders.",!!
+7 IF ORTYPE="A"
IF 'STAT
WRITE !!,"Inactivating auto-dc rules takes effect immediately.",!
+8 IF STAT
IF $GET(EVNTYPE)="O"
IF $$ACTSURG^OREV4(ORTYPE,DA)
Begin DoDot:1
+9 WRITE !,NAME,!,"can not be activated because you already have an active surgery rule for this",!,"division. Only one active surgery rule per division is allowed.",!
+10 SET DIR(0)="E"
SET DIR("A")="Press enter to continue"
DO ^DIR
KILL DIR
End DoDot:1
QUIT
+11 ;If inactive child event and parent is inactive don't activate child
IF STAT
IF ORTYPE="E"
IF $PIECE($GET(^ORD(100.5,DA,0)),U,12)
IF $GET(^ORD(100.5,$PIECE(^(0),U,12),1))
Begin DoDot:1
+12 WRITE !,NAME,!,"can not be activated until its parent event is active.",!
+13 SET DIR(0)="E"
SET DIR("A")="Press enter to continue"
DO ^DIR
KILL DIR
End DoDot:1
QUIT
+14 IF STAT
IF ORTYPE="E"
IF '$$CANACT(DA,.USED)
Begin DoDot:1
+15 WRITE !,NAME,!,"can not be activated because the following locations",!,"and/or treating specialties are currently in use by other entries.",!
+16 FOR MULT="LOC","TS"
if $DATA(USED(MULT))
WRITE !,$SELECT(MULT="LOC":"LOCATIONS:",1:"TREATING SPECIALTIES:"),!
Begin DoDot:2
+17 SET IEN=0
FOR
SET IEN=$ORDER(USED(MULT,IEN))
if '+IEN
QUIT
Begin DoDot:3
+18 SET SUB=0
FOR
SET SUB=$ORDER(USED(MULT,IEN,SUB))
if '+SUB
QUIT
Begin DoDot:4
+19 WRITE !,$SELECT(MULT="LOC":$PIECE($GET(^DIC(42,SUB,0)),"^"),1:$PIECE($GET(^DIC(45.7,SUB,0)),"^"))," is in use by ",$PIECE($GET(@(ORGLOB_IEN_",0)")),"^"),!
End DoDot:4
End DoDot:3
End DoDot:2
+20 WRITE !,"For active entries, LOCATIONS and TREATING SPECIALTIES",!,"must be unique within division and event type."
+21 SET DIR(0)="E"
SET DIR("A")="Press enter to continue"
DO ^DIR
KILL DIR
End DoDot:1
QUIT
+22 IF STAT
IF ORTYPE="A"
IF '$$CANACT(DA,.USED)
Begin DoDot:1
+23 WRITE !,NAME,!,"can not be activated because the following MAS movements",!,"are currently in use by other entries.",!
+24 SET IEN=0
FOR
SET IEN=$ORDER(USED(IEN))
if '+IEN
QUIT
Begin DoDot:2
+25 SET SUB=0
FOR
SET SUB=$ORDER(USED(IEN,SUB))
if '+SUB
QUIT
Begin DoDot:3
+26 WRITE !,$PIECE($GET(^DG(405.2,IEN,0)),U)," is in use by ",$PIECE($GET(^ORD(100.6,SUB,0)),U)
End DoDot:3
End DoDot:2
+27 WRITE !,"For active entries, MAS movements within DIVISION must be unique."
+28 SET DIR(0)="E"
SET DIR("A")="Press return to continue"
DO ^DIR
KILL DIR
End DoDot:1
QUIT
+29 ;
+30 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Are you sure you want to "_$SELECT(STAT:"",1:"IN")_"ACTIVATE this entry"
DO ^DIR
+31 IF Y'=1
WRITE !,"Nothing changed!"
QUIT
+32 SET DIE=ORGLOB
SET DR="1///"_$SELECT(STAT:"@",1:CDT)
DO ^DIE
WRITE !,NAME," is now "_$SELECT(STAT:"",1:"IN")_"ACTIVATED!"
+33 IF 'STAT
SET DA(1)=DA
SET DA=$ORDER(@(ORGLOB_DA(1)_",2,"_"""ACT"""_",0)"))
SET DIE=ORGLOB_DA(1)_",2,"
SET DR="1///"_CDT
DO ^DIE
if ORTYPE="E"
DO UPDTCHLD^OREV3(DA(1),CDT)
QUIT
+34 DO SET(DA,CDT)
+35 QUIT
+36 ;
SET(MIEN,X) ;add new multiple to activation history
+1 NEW DIC,DA
+2 SET DA(1)=MIEN
+3 SET DIC=ORGLOB_DA(1)_",2,"
SET DIC(0)="L"
+4 DO FILE^DICN
+5 QUIT
+6 ;
INUSE(MULT) ;determine if location or treating specialty is already in use
+1 NEW ACTIVE,USED,NAME,TYPE,DIV,FMIEN
+2 SET USED=0
SET NAME=""
SET FMIEN=$GET(DA(1),DA)
+3 ;movement type of entry being checked
SET TYPE=$PIECE($GET(^ORD(100.5,FMIEN,0)),"^",2)
+4 ;division of entry being checked
SET DIV=$PIECE($GET(^ORD(100.5,FMIEN,0)),"^",3)
+5 FOR
SET NAME=$ORDER(^ORD(100.5,"C",NAME))
if NAME=""!(USED)
QUIT
Begin DoDot:1
+6 SET ACTIVE=0
FOR
SET ACTIVE=$ORDER(^ORD(100.5,"C",NAME,ACTIVE))
if '+ACTIVE!USED
QUIT
Begin DoDot:2
+7 ;stop processing if not same division
if DIV'=$PIECE($GET(^ORD(100.5,ACTIVE,0)),"^",3)
QUIT
+8 ;stop processing if not the same type
if TYPE'=$PIECE($GET(^ORD(100.5,ACTIVE,0)),"^",2)
QUIT
+9 SET USED=$DATA(^ORD(100.5,ACTIVE,MULT,"B",Y))
IF USED
SET WHO=ACTIVE
End DoDot:2
End DoDot:1
+10 QUIT USED
+11 ;
CANACT(DA,USED) ;Function returns whether or not an entry can be activated.
+1 ;For EVENTS, locations and specialties must be unique within division
+2 ;and EVENT TYPE. For AUTO DC, movement types must be unique within
+3 ;division.
+4 NEW MULT,SUB,Y,CANACT,WHO
+5 SET CANACT=1
+6 IF ORTYPE="E"
FOR MULT="LOC","TS"
Begin DoDot:1
+7 SET SUB=0
FOR
SET SUB=$ORDER(^ORD(100.5,DA,MULT,SUB))
if '+SUB
QUIT
Begin DoDot:2
+8 SET Y=$GET(^(SUB,0))
IF Y
IF $$INUSE(MULT)
SET CANACT=0
SET USED(MULT,WHO,Y)=""
End DoDot:2
End DoDot:1
+9 ;
+10 IF ORTYPE="A"
Begin DoDot:1
+11 SET SUB=0
FOR
SET SUB=$ORDER(^ORD(100.6,DA,3,SUB))
if '+SUB
QUIT
Begin DoDot:2
+12 SET Y=+$GET(^(SUB,0))
IF Y
IF $$INUSEDC()
SET CANACT=0
SET USED(Y,WHO)=""
End DoDot:2
End DoDot:1
+13 QUIT CANACT
+14 ;
INUSEDC() ;Checks AUTO-DC rules for unique movement types
+1 NEW DIV,USED
+2 SET USED=0
+3 SET DIV=+$PIECE($GET(^ORD(100.6,DA,0)),U,3)
+4 IF DIV
IF $DATA(^ORD(100.6,"AC",DIV,Y))
SET WHO=$ORDER(^(Y,0))
SET USED=1
+5 QUIT USED
+6 ;
HASREQD() ;Function returns whether entry has required entries or not
+1 NEW REQD
+2 SET REQD=0
+3 IF ORTYPE="E"
Begin DoDot:1
+4 ;From pass (transfer) doesn't require treating specialty
IF "^22^23^24^"[("^"_$PIECE($GET(^ORD(100.5,DA,0)),U,7)_"^")
SET REQD=1
QUIT
+5 ;Has locations or treating specialties
IF $ORDER(^ORD(100.5,DA,"LOC",0))>0!($ORDER(^ORD(100.5,DA,"TS",0))>0)
SET REQD=1
+6 ;Warn user that both must be true if both defined.
IF $ORDER(^ORD(100.5,DA,"LOC",0))>0&($ORDER(^ORD(100.5,DA,"TS",0))>0)
SET REQD=2
End DoDot:1
+7 IF ORTYPE="A"
Begin DoDot:1
+8 ;If type is operating room then movements not required
IF $PIECE($GET(^ORD(100.6,DA,0)),U,2)="O"
SET REQD=1
+9 ;movement type exists
IF $PIECE($GET(^ORD(100.6,DA,0)),U,2)'="O"&($ORDER(^ORD(100.6,DA,3,0))>0)
SET REQD=1
+10 ;If transfer type and interward transfer type not by itself
IF $PIECE($GET(^ORD(100.6,DA,0)),U,2)="T"
IF $DATA(^ORD(100.6,DA,3,"B",4))
IF $PIECE($GET(^ORD(100.6,DA,3,0)),U,4)>1
SET REQD=2
End DoDot:1
+11 QUIT REQD
+12 ;
CHKTYP(IEN) ;Check type of event and delete fields that are no longer needed based on the event type
+1 NEW J,DR,DIE,DA,DIC,TYPE
+2 IF ORTYPE="E"
Begin DoDot:1
+3 SET TYPE=$PIECE(^ORD(100.5,IEN,0),U,2)
+4 ;if not admit or transfer delete locations and treating specialties
IF TYPE'="A"&(TYPE'="T")
DO DELMUL(100.5,IEN,"""LOC""")
DO DELMUL(100.5,IEN,"""TS""")
+5 ;Delete MAS MOVEMENT when type changes as movement types are associated with event type
SET DA=IEN
SET DIE=100.5
SET DR="7///@"
DO ^DIE
End DoDot:1
QUIT
+6 ;If not event type must be auto-dc
+7 SET TYPE=$PIECE(^ORD(100.6,IEN,0),U,2)
+8 ;Delete 'except from observation" if not discharge type
IF TYPE'="D"
SET DA=IEN
SET DIE=100.6
SET DR="6///@"
DO ^DIE
+9 ;delete MAS MOVEMENT
DO DELMUL(100.6,IEN,3)
+10 ;If not specialty type delete excluded treating specialties
IF TYPE'="S"
DO DELMUL(100.6,IEN,4)
+11 ;If not transfer type delete included locations and included divisions
IF TYPE'="T"
DO DELMUL(100.6,IEN,5)
DO DELMUL(100.6,IEN,6)
+12 QUIT
+13 ;
ORDERS(ACTION) ; -- Return order numbers to act on, if action chosen first
+1 NEW X,Y,DIR,MAX
+2 SET MAX=$GET(VALMCNT)
if MAX'>0
QUIT ""
+3 IF ACTION="edit"
WRITE !!,"Enter item number to edit or press enter to create a new entry"
+4 SET DIR(0)="LAO^1:"_MAX
SET DIR("A")="Select item(s): "
+5 SET DIR("?")="Enter the items you wish to "_ACTION_", as a range or list of numbers."_$SELECT(ACTION="edit":" Press enter to create a NEW entry",1:"")
+6 DO ^DIR
if $DATA(DTOUT)
SET Y="^"
+7 IF $DATA(Y(1))
WRITE !,">>>Too many entries selected, try using smaller ranges"
HANG 2
SET Y="^"
+8 QUIT Y
+9 ;
+10 ;
CANDEL(FILE) ;Determines if event or rule can be deleted
+1 NEW DEL,EVENT,LIST,I,J
+2 SET DEL=1
+3 SET EVENT=$ORDER(^XTV(8989.51,"B","ORWDX WRITE ORDERS EVENT LIST",0))
+4 SET LIST=$ORDER(^XTV(8989.51,"B","OREVNT COMMON LIST",0))
+5 IF FILE=100.5
Begin DoDot:1
+6 IF $ORDER(^ORE(100.2,"E",DA,0))
WRITE !,"< Can't delete this event because file 100.2 is pointing to it > "
SET DEL=0
QUIT
+7 IF $DATA(^ORD(100.5,"DAD",DA))
WRITE !,"< Can't delete parent events that have children > "
SET DEL=0
QUIT
+8 SET FND=0
+9 KILL LST
DO ENVAL^XPAR(.LST,LIST)
+10 SET I=""
FOR
SET I=$ORDER(LST(I))
if I=""!(FND)
QUIT
Begin DoDot:2
+11 SET J=""
FOR
SET J=$ORDER(LST(I,J))
if J=""!(FND)
QUIT
IF LST(I,J)=DA
SET FND=1
End DoDot:2
+12 IF 'FND
KILL LST
DO ENVAL^XPAR(.LST,EVENT)
Begin DoDot:2
+13 SET I=""
FOR
SET I=$ORDER(LST(I))
if I=""!(FND)
QUIT
Begin DoDot:3
+14 SET J=""
FOR
SET J=$ORDER(LST(I,J))
if J=""!(FND)
QUIT
IF DA=J
SET FND=1
End DoDot:3
End DoDot:2
+15 IF FND
WRITE !,"< Can't delete event because parameters are pointing to it > "
SET DEL=0
End DoDot:1
+16 ;
+17 IF FILE=100.6
Begin DoDot:1
+18 IF $ORDER(^ORE(100.2,"DC",DA,0))
SET DEL=0
WRITE !,"< Can't delete this rule because file 100.2 is pointing to it > "
QUIT
End DoDot:1
+19 ;
+20 ;Reverse value of DEL so that $T is set correctly for fileman to determine if entry can be deleted. Code is in ^DD(file#,.01,"DEL",.01,0)
QUIT 'DEL
+21 ;
ASKOBS() ;Function to determine if 'except from observation' field should be asked.
+1 NEW ANS
+2 SET ANS=1
+3 ;Don't ask if MAS MOVEMENT TYPE is 12 (death) or 38 (death with autopsy)
IF ETYPE="D"
IF $DATA(^ORD(100.6,DA,3,"B",12))!($DATA(^ORD(100.6,DA,3,"B",38)))
SET ANS=0
+4 ;If MAS MOVEMENT TYPE doesn't contain FROM ASIH (VAH) when type is transfer then don't ask
IF ETYPE="T"
IF '$DATA(^ORD(100.6,DA,3,"B",14))
SET ANS=0
+5 QUIT ANS
+6 ;
DELMUL(FILE,IEN,LOC) ;Delete multiple entries for entry IEN in file FILE stored at location LOC
+1 NEW I,DR,DIE,DA,DIC,GLOB,Y,DQ,DP,DL,DM,DI,DK
+2 SET GLOB="^ORD("_FILE_","_IEN_","
+3 SET I=0
FOR
SET I=$ORDER(@(GLOB_LOC_","_I_")"))
if '+I
QUIT
SET DA(1)=IEN
SET DA=I
SET DR=".01///@"
SET DIE="^ORD("_FILE_",DA(1),"_LOC_","
DO ^DIE
+4 QUIT
+5 ;
RELEVNTS(DA) ;Check to see if release event is currently being pointed to
+1 NEW DFN,EVENT
+2 SET (DFN,EVENT)=0
+3 FOR
SET DFN=$ORDER(^ORE(100.2,"AE",DFN))
if '+DFN
QUIT
IF $DATA(^ORE(100.2,"AE",DFN,DA))
SET EVENT=1
QUIT
+4 QUIT EVENT
