OREV3 ;SLC/DAN Event delayed orders set up continued ;12/23/02 13:28
;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,165**;Dec 17, 1997
;DBIA reference section
;10116 - VALM1
;2324 - USRLM
;10009 - DICN
;2056 - DIQ
;2336 - XPAREDIT
;2263 - XPAR
;10006 - DIC
;10026 - DIR
;10018 - DIE
;10103 - XLFDT
;
ACE ;Add child events to existing events
N DIC,ORJ,ORTMP,DA,Y,ORGLOB,ADD
D FULL^VALM1 ;get full screen
S VALMBCK="R"
S (DIC,ORGLOB)="^ORD(100.5,"
I $G(ORNMBR)="" S ORNMBR=$$ORDERS^OREV1("add child events to") Q:ORNMBR="^" ;If action selected before items, get items
I $G(ORNMBR)="" D Q
.S DIC(0)="AEMQ",DIC("S")="I '+$P($G(^(0)),U,12)" ;Screen children from being parents
.D ^DIC Q:Y=-1 S DA=+Y
.Q:'$$PARENTOK^OREV4
.L +@(ORGLOB_DA_")"):1 I '$T W !!,"This entry is being edited by another user." H 3 Q
.W !!,"Adding children to parent ",$P(^ORD(100.5,DA,0),U)
.D ADDCHLD(DA,.ADD) ;Add child to selected event
.I $G(ADD) D AUDIT^OREV(DA,"E"),CHKPRM^OREV4 ;If child event added update audit history and check parameters
.L -@(ORGLOB_DA_")")
F ORJ=1:1:$L(ORNMBR,",")-1 S ORTMP=$P(ORNMBR,",",ORJ),DA=$O(^TMP("OREDO",$J,"IDX",ORTMP,0)) D
.I $P($G(^ORD(100.5,DA,0)),U,12) W !!,"You may not add child events to events that are already children.",!,$P($G(^ORD(100.5,DA,0)),U)," - SKIPPED!",! H 3 Q
.Q:'$$PARENTOK^OREV4
.L +@(ORGLOB_DA_")"):1 I '$T W !!,"This entry is being edited by another user." H 3 Q ;Lock global
.W !!,"Adding children to parent ",$P(^ORD(100.5,DA,0),U)
.D ADDCHLD(DA,.ADD) ;Add child to selected event
.I $G(ADD) D AUDIT^OREV(DA,"E"),CHKPRM^OREV4 ;If child event added update audit history and check paramters
.L -@(ORGLOB_DA_")") ;Unlock global
Q
;
ADDCHLD(ENTRY,ADD) ;Add child(ren) to event
;ENTRY - Internal entry number of event that will be the parent
;ADD - Will be set to 1 if a child is successfully added
;
N DIR,Y,DIC,DIE,DA,DR,DIRUT,X,NEW
F D Q:$G(DIRUT)
.W !
.S DIR(0)="FAO^3:50"
.S DIR("A")="OE/RR CHILD RELEASE EVENT NAME: "
.S DIR("?")="Enter the name of the child event you wish to create. It must be free text between 3 and 50 characters and be unique."
.D ^DIR
.Q:$G(DIRUT)
.I $D(^ORD(100.5,"B",Y)) W !,"There is already an entry with this name. Please select a different name." Q
.S DIC="^ORD(100.5,",DIC(0)="",X=Y D FILE^DICN ;Add child to file
.Q:Y=-1
.S DIE=DIC
.S DR="[OREV CHILD EVENT"
.S DA=+Y
.S NEW=1
.D ^DIE
.Q:'$G(DA) ;Child event deleted, stop processing
.D AUDIT^OREV(DA,"N") ;Update audit history for child
.S DR="1///"_$$NOW^XLFDT_";14///`"_ENTRY D ^DIE ;Add parent pointer to child entry
.S ADD=1 ;Indicate that child was added
.W !!,"Enter next child name or press enter to stop adding children."
Q
;
UPDTCHLD(PARENT,CDT) ;Update children to inactive when parent is inactivated
N DA,DIE,CHILD,DR,DONE
S DONE=0
S CHILD="" F S CHILD=$O(^ORD(100.5,"DAD",PARENT,CHILD)) Q:'+CHILD D
.I 'DONE W !!,"Updating children..." S DONE=1
.Q:$G(^ORD(100.5,CHILD,1)) ;Child is already inactive
.S DA=CHILD
.S DIE="^ORD(100.5,"
.S DR="1///"_CDT
.D ^DIE ;Sets inactivated date/time for child
.;
.S DA(1)=DA
.S DA=$O(^ORD(100.5,DA(1),2,"ACT",0))
.S DIE="^ORD(100.5,DA(1),2,"
.S DR="1///"_CDT
.D ^DIE ;Update inactivated date/time of activation multiple for child
Q
;
PARAM ;Allow user to edit event delayed order parameters
N DIR,Y
S VALMBCK="R" D FULL^VALM1
F D Q:'Y
.S DIR(0)="SO^1:Write orders list by event;2:Default release event;3:Common release event list;4:Manual release controlled by;5:Set manual release parameter;6:Exclude display groups from copy"
.S DIR("A")="Select parameter to edit"
.D ^DIR Q:'Y
.I Y=2!(Y=3) D:Y=2 SETDFLT() D:Y=3 EVENTLST Q
.D EDITPAR^XPAREDIT($S(Y=1:"ORWDX WRITE ORDERS EVENT LIST",Y=4:"OREVNT MANUAL RELEASE CONTROL",Y=5:"OREVNT MANUAL RELEASE",1:"OREVNT EXCLUDE DGRP"))
Q
;
CANREL() ;Function to determine if delayed order can be manually released
N ORMAN,CAN
S ORMAN=$$GET^XPAR("ALL","OREVNT MANUAL RELEASE CONTROL")
S:ORMAN="" ORMAN="K" ;If no value found, default to checking for keys
I ORMAN="K",'$$KEY Q 0
I ORMAN="P",'$$MANPARAM Q 0
I ORMAN="B" D Q:$G(CAN)=0 0
.I $$KEY,$$MANPARAM=0 S CAN=0 Q
.I '$$KEY,'$$MANPARAM S CAN=0
Q 1
;
KEY() ;Check for ORES or ORELSE keys
I '$D(^XUSEC("ORES",DUZ))&('$D(^XUSEC("ORELSE",DUZ))) Q 0
Q 1
;
MANPARAM() ;Check setting of OREVNT MANUAL RELEASE parameter
N LST,I,FND,PRM,X,Y,DIC,EXP,STR,VAL,FNDNO
S DIC=8989.51,DIC(0)="MX",X="OREVNT MANUAL RELEASE" D ^DIC
I Y=-1 Q 0 ;Parameter not found so quit
S PRM=+Y
;Check USER level
S VAL=$$GET^XPAR("USR",PRM) I VAL'="" Q VAL
;Check USER CLASS
D WHATIS^USRLM(DUZ,"LST")
I $O(LST(0))'="" D I FND'="" Q FND
.S FND=""
.S I=0 F S I=$O(LST(I)) Q:I=""!(FND) S EXP=+$P(LST(I),U,5),STR=+$P(LST(I),U,4) I 'EXP!(EXP'<DT) I 'STR!(STR'>DT) S FND=$G(^XTV(8989.5,"AC",PRM,$P(LST(I),U)_";USR(8930,",1)) I FND=0 S FNDNO=1
.I 'FND,$G(FNDNO) S FND=0
;Check OE/RR Teams
K LST,FNDNO
D TEAMPR^ORQPTQ1(.LST,DUZ)
I +$G(LST(1)) D I FND'="" Q FND
.S FND=""
.S I=0 F S I=$O(LST(I)) Q:I=""!(FND) S FND=$G(^XTV(8989.5,"AC",PRM,$P(LST(I),U)_";OR(100.21,",1)) S:FND=0 FNDNO=1
.I 'FND,$G(FNDNO) S FND=0
;Check location
I +$G(LOC) S VAL=$$GET^XPAR("LOC.`"_+$G(LOC),PRM) I VAL'="" Q VAL
;Check Service
S VAL=$G(^XTV(8989.5,"AC",PRM,+$$GET1^DIQ(200,DUZ,29,"I")_";DIC(49,",1)) I VAL'="" Q VAL
;Check Division and System
S VAL=$$GET^XPAR("DIV^SYS",PRM) I VAL'="" Q VAL
Q ""
;
DEFHELP ;Provide detailed help for setting default treating specialty
N DEF,DEFTS,DEFTSNM
I $D(^ORD(100.5,DA(1),"TS","DEF")) D Q
.S DEF=$O(^ORD(100.5,DA(1),"TS","DEF",1,0))
.I DEF=DA Q ;Default is current entry
.S DEFTS=$P(^ORD(100.5,DA(1),"TS",DEF,0),U)
.S DEFTSNM=$$GET1^DIQ(45.7,DEFTS_",",.01)
.W !?5,"You may not set this treating specialty as the default because"
.W !?5,DEFTSNM," is already set as the default."
.W !?5,"If you would like to change the default you must first delete the",!?5,"default designation from the above mentioned treating specialty.",!
;
W !?5,"Currently there is no default treating specialty set for this event.",!
Q
;
EVENTLST ;Allow user to edit OREVNT COMMON LIST parameter and set a default for that list
N DIC,X,Y,PRM,ORENT
S DIC=8989.51,DIC(0)="MX",X="OREVNT COMMON LIST" D ^DIC
Q:Y=-1 ;Parameter doesn't exist
S PRM=Y
D GETENT^XPAREDIT(.ORENT,PRM)
Q:ORENT="" ;Nothing selected
D EDIT^XPAREDIT(ORENT,PRM) ;edit selected entity
Q:$G(DUOUT)!($G(DTOUT)) ;User ^ or timed out
I '$D(^XTV(8989.5,"AC",+PRM,ORENT)) Q ;No value stored for entity don't ask for default
D SETDFLT(ORENT,PRM)
Q
;
SETDFLT(ORENT,PRM) ;Set default for given list
N DIC,Y,X,PRMD,DEF,I,J,DIR,FND,ORLST
I $G(PRM)="" S DIC=8989.51,DIC(0)="MX",X="OREVNT COMMON LIST" D ^DIC Q:Y=-1 S PRM=Y
S DIC=8989.51,DIC(0)="MX",X="OREVNT DEFAULT" D ^DIC
Q:Y=-1 ;Parameter doesn't exist
S PRMD=Y
I $G(ORENT)="" D GETENT^XPAREDIT(.ORENT,PRMD) Q:ORENT="" ;Nothing selected
D GETLST^XPAR(.ORLST,ORENT,+PRM)
I ORLST=0 W !!,"No common list is defined for this entity and therefore a default",!,"may not be set. Create a common list first.",! Q
S DEF=$$GET^XPAR(ORENT,+PRMD,,"B") F I=1:1:ORLST I $P(ORLST(I),U,2)=+DEF S FND=1
I '$G(FND) S DEF="" D EN^XPAR(ORENT,+PRMD,,"@") ;Delete default if no longer in list
W !!,$S(DEF'="":"Current DEFAULT is "_$P(DEF,U,2)_$S($G(^ORD(100.5,+DEF,1)):" (*INACTIVE*)",1:""),1:"No DEFAULT has been set yet.")
W ! F J=1:1:ORLST W !,J,") ",$P(^ORD(100.5,$P(ORLST(J),U,2),0),U),$S($G(^(1)):" (*INACTIVE*)",1:"")
I DEF'="" S ORLST=ORLST+1 W !!,ORLST,") DELETE CURRENT DEFAULT"
W ! S DIR(0)="NO^1:"_ORLST,DIR("A")="Select default release event"_$S(DEF'="":" or delete current event",1:"") D ^DIR
I 'Y Q ;No selection made
I Y=ORLST&(DEF'="") D EN^XPAR(ORENT,+PRMD,,"@") W !,"Default deleted" Q
I $G(^ORD(100.5,$P(ORLST(Y),U,2),1)) W !,"You cannot set an inactive event as the default." Q ;No inactive defaults can be set
;write updated parameter
D EN^XPAR(ORENT,+PRMD,,"`"_$P(ORLST(Y),"^",2))
Q
;
GETLST(LST) ;Return common list and default event
N I,FND,PRM,X,Y,DIC,TLST,ORCLST,ENT,EXP,STR
S DIC=8989.51,DIC(0)="MX",X="OREVNT COMMON LIST" D ^DIC
I Y=-1 Q ;Parameter not found so quit
S PRM=+Y
D ENVAL^XPAR(.ORCLST,PRM) Q:ORCLST=0 ;Nothing defined at any level
;Check USER level
S ENT=DUZ_";VA(200," I $D(ORCLST(ENT)) D RETLST Q
;Check USER CLASS
D WHATIS^USRLM(DUZ,"TLST")
I $O(TLST(0))'="" D I FND Q
.S FND=0
.S I=0 F S I=$O(TLST(I)) Q:I=""!(FND) S ENT=$P(TLST(I),U)_";USR(8930," S EXP=+$P(TLST(I),U,5),STR=+$P(TLST(I),U,4) I 'EXP!(EXP'<DT) I 'STR!(STR'>DT) I $D(ORCLST(ENT)) D RETLST S FND=1
;Check OE/RR Teams
K TLST
D TEAMPR^ORQPTQ1(.TLST,DUZ)
I +$G(TLST(1)) D I FND Q
.S FND=0
.S I=0 F S I=$O(TLST(I)) Q:I=""!(FND) S ENT=$P(TLST(I),U)_"OR(100.21," I $D(ORCLST(ENT)) D RETLST S FND=1
;Check location
I +$G(LOC) S ENT=+LOC_";SC(" I $D(ORCLST(ENT)) D RETLST Q
;Check Service
S ENT=$$GET1^DIQ(200,DUZ,29,"I")_";DIC(49,"
I $D(ORCLST(ENT)) D RETLST Q
;Check Division
S ENT=DUZ(2)_";DIC(4," I $D(ORCLST(ENT)) D RETLST Q
Q
;
RETLST ;Sets up list for entity
N DEF,Y,DIC,I,CNT,X
S DIC=8989.51,DIC(0)="MQ",X="OREVNT DEFAULT" D ^DIC
Q:'Y ;Stop if parameter doesn't exist
S CNT=1
S DEF=$$GET^XPAR(ENT,+Y,,"B")
S I=0 F S I=$O(ORCLST(ENT,I)) Q:'+I I '$G(^ORD(100.5,ORCLST(ENT,I),1))&('$D(^ORD(100.5,"DAD",ORCLST(ENT,I)))) S LST(CNT)=ORCLST(ENT,I) S:ORCLST(ENT,I)=+DEF $P(LST(CNT),U,2)=1 S CNT=CNT+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HOREV3 9675 printed Nov 22, 2024@17:40:37 Page 2
OREV3 ;SLC/DAN Event delayed orders set up continued ;12/23/02 13:28
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,165**;Dec 17, 1997
+2 ;DBIA reference section
+3 ;10116 - VALM1
+4 ;2324 - USRLM
+5 ;10009 - DICN
+6 ;2056 - DIQ
+7 ;2336 - XPAREDIT
+8 ;2263 - XPAR
+9 ;10006 - DIC
+10 ;10026 - DIR
+11 ;10018 - DIE
+12 ;10103 - XLFDT
+13 ;
ACE ;Add child events to existing events
+1 NEW DIC,ORJ,ORTMP,DA,Y,ORGLOB,ADD
+2 ;get full screen
DO FULL^VALM1
+3 SET VALMBCK="R"
+4 SET (DIC,ORGLOB)="^ORD(100.5,"
+5 ;If action selected before items, get items
IF $GET(ORNMBR)=""
SET ORNMBR=$$ORDERS^OREV1("add child events to")
if ORNMBR="^"
QUIT
+6 IF $GET(ORNMBR)=""
Begin DoDot:1
+7 ;Screen children from being parents
SET DIC(0)="AEMQ"
SET DIC("S")="I '+$P($G(^(0)),U,12)"
+8 DO ^DIC
if Y=-1
QUIT
SET DA=+Y
+9 if '$$PARENTOK^OREV4
QUIT
+10 LOCK +@(ORGLOB_DA_")"):1
IF '$TEST
WRITE !!,"This entry is being edited by another user."
HANG 3
QUIT
+11 WRITE !!,"Adding children to parent ",$PIECE(^ORD(100.5,DA,0),U)
+12 ;Add child to selected event
DO ADDCHLD(DA,.ADD)
+13 ;If child event added update audit history and check parameters
IF $GET(ADD)
DO AUDIT^OREV(DA,"E")
DO CHKPRM^OREV4
+14 LOCK -@(ORGLOB_DA_")")
End DoDot:1
QUIT
+15 FOR ORJ=1:1:$LENGTH(ORNMBR,",")-1
SET ORTMP=$PIECE(ORNMBR,",",ORJ)
SET DA=$ORDER(^TMP("OREDO",$JOB,"IDX",ORTMP,0))
Begin DoDot:1
+16 IF $PIECE($GET(^ORD(100.5,DA,0)),U,12)
WRITE !!,"You may not add child events to events that are already children.",!,$PIECE($GET(^ORD(100.5,DA,0)),U)," - SKIPPED!",!
HANG 3
QUIT
+17 if '$$PARENTOK^OREV4
QUIT
+18 ;Lock global
LOCK +@(ORGLOB_DA_")"):1
IF '$TEST
WRITE !!,"This entry is being edited by another user."
HANG 3
QUIT
+19 WRITE !!,"Adding children to parent ",$PIECE(^ORD(100.5,DA,0),U)
+20 ;Add child to selected event
DO ADDCHLD(DA,.ADD)
+21 ;If child event added update audit history and check paramters
IF $GET(ADD)
DO AUDIT^OREV(DA,"E")
DO CHKPRM^OREV4
+22 ;Unlock global
LOCK -@(ORGLOB_DA_")")
End DoDot:1
+23 QUIT
+24 ;
ADDCHLD(ENTRY,ADD) ;Add child(ren) to event
+1 ;ENTRY - Internal entry number of event that will be the parent
+2 ;ADD - Will be set to 1 if a child is successfully added
+3 ;
+4 NEW DIR,Y,DIC,DIE,DA,DR,DIRUT,X,NEW
+5 FOR
Begin DoDot:1
+6 WRITE !
+7 SET DIR(0)="FAO^3:50"
+8 SET DIR("A")="OE/RR CHILD RELEASE EVENT NAME: "
+9 SET DIR("?")="Enter the name of the child event you wish to create. It must be free text between 3 and 50 characters and be unique."
+10 DO ^DIR
+11 if $GET(DIRUT)
QUIT
+12 IF $DATA(^ORD(100.5,"B",Y))
WRITE !,"There is already an entry with this name. Please select a different name."
QUIT
+13 ;Add child to file
SET DIC="^ORD(100.5,"
SET DIC(0)=""
SET X=Y
DO FILE^DICN
+14 if Y=-1
QUIT
+15 SET DIE=DIC
+16 SET DR="[OREV CHILD EVENT"
+17 SET DA=+Y
+18 SET NEW=1
+19 DO ^DIE
+20 ;Child event deleted, stop processing
if '$GET(DA)
QUIT
+21 ;Update audit history for child
DO AUDIT^OREV(DA,"N")
+22 ;Add parent pointer to child entry
SET DR="1///"_$$NOW^XLFDT_";14///`"_ENTRY
DO ^DIE
+23 ;Indicate that child was added
SET ADD=1
+24 WRITE !!,"Enter next child name or press enter to stop adding children."
End DoDot:1
if $GET(DIRUT)
QUIT
+25 QUIT
+26 ;
UPDTCHLD(PARENT,CDT) ;Update children to inactive when parent is inactivated
+1 NEW DA,DIE,CHILD,DR,DONE
+2 SET DONE=0
+3 SET CHILD=""
FOR
SET CHILD=$ORDER(^ORD(100.5,"DAD",PARENT,CHILD))
if '+CHILD
QUIT
Begin DoDot:1
+4 IF 'DONE
WRITE !!,"Updating children..."
SET DONE=1
+5 ;Child is already inactive
if $GET(^ORD(100.5,CHILD,1))
QUIT
+6 SET DA=CHILD
+7 SET DIE="^ORD(100.5,"
+8 SET DR="1///"_CDT
+9 ;Sets inactivated date/time for child
DO ^DIE
+10 ;
+11 SET DA(1)=DA
+12 SET DA=$ORDER(^ORD(100.5,DA(1),2,"ACT",0))
+13 SET DIE="^ORD(100.5,DA(1),2,"
+14 SET DR="1///"_CDT
+15 ;Update inactivated date/time of activation multiple for child
DO ^DIE
End DoDot:1
+16 QUIT
+17 ;
PARAM ;Allow user to edit event delayed order parameters
+1 NEW DIR,Y
+2 SET VALMBCK="R"
DO FULL^VALM1
+3 FOR
Begin DoDot:1
+4 SET DIR(0)="SO^1:Write orders list by event;2:Default release event;3:Common release event list;4:Manual release controlled by;5:Set manual release parameter;6:Exclude display groups from copy"
+5 SET DIR("A")="Select parameter to edit"
+6 DO ^DIR
if 'Y
QUIT
+7 IF Y=2!(Y=3)
if Y=2
DO SETDFLT()
if Y=3
DO EVENTLST
QUIT
+8 DO EDITPAR^XPAREDIT($SELECT(Y=1:"ORWDX WRITE ORDERS EVENT LIST",Y=4:"OREVNT MANUAL RELEASE CONTROL",Y=5:"OREVNT MANUAL RELEASE",1:"OREVNT EXCLUDE DGRP"))
End DoDot:1
if 'Y
QUIT
+9 QUIT
+10 ;
CANREL() ;Function to determine if delayed order can be manually released
+1 NEW ORMAN,CAN
+2 SET ORMAN=$$GET^XPAR("ALL","OREVNT MANUAL RELEASE CONTROL")
+3 ;If no value found, default to checking for keys
if ORMAN=""
SET ORMAN="K"
+4 IF ORMAN="K"
IF '$$KEY
QUIT 0
+5 IF ORMAN="P"
IF '$$MANPARAM
QUIT 0
+6 IF ORMAN="B"
Begin DoDot:1
+7 IF $$KEY
IF $$MANPARAM=0
SET CAN=0
QUIT
+8 IF '$$KEY
IF '$$MANPARAM
SET CAN=0
End DoDot:1
if $GET(CAN)=0
QUIT 0
+9 QUIT 1
+10 ;
KEY() ;Check for ORES or ORELSE keys
+1 IF '$DATA(^XUSEC("ORES",DUZ))&('$DATA(^XUSEC("ORELSE",DUZ)))
QUIT 0
+2 QUIT 1
+3 ;
MANPARAM() ;Check setting of OREVNT MANUAL RELEASE parameter
+1 NEW LST,I,FND,PRM,X,Y,DIC,EXP,STR,VAL,FNDNO
+2 SET DIC=8989.51
SET DIC(0)="MX"
SET X="OREVNT MANUAL RELEASE"
DO ^DIC
+3 ;Parameter not found so quit
IF Y=-1
QUIT 0
+4 SET PRM=+Y
+5 ;Check USER level
+6 SET VAL=$$GET^XPAR("USR",PRM)
IF VAL'=""
QUIT VAL
+7 ;Check USER CLASS
+8 DO WHATIS^USRLM(DUZ,"LST")
+9 IF $ORDER(LST(0))'=""
Begin DoDot:1
+10 SET FND=""
+11 SET I=0
FOR
SET I=$ORDER(LST(I))
if I=""!(FND)
QUIT
SET EXP=+$PIECE(LST(I),U,5)
SET STR=+$PIECE(LST(I),U,4)
IF 'EXP!(EXP'<DT)
IF 'STR!(STR'>DT)
SET FND=$GET(^XTV(8989.5,"AC",PRM,$PIECE(LST(I),U)_";USR(8930,",1))
IF FND=0
SET FNDNO=1
+12 IF 'FND
IF $GET(FNDNO)
SET FND=0
End DoDot:1
IF FND'=""
QUIT FND
+13 ;Check OE/RR Teams
+14 KILL LST,FNDNO
+15 DO TEAMPR^ORQPTQ1(.LST,DUZ)
+16 IF +$GET(LST(1))
Begin DoDot:1
+17 SET FND=""
+18 SET I=0
FOR
SET I=$ORDER(LST(I))
if I=""!(FND)
QUIT
SET FND=$GET(^XTV(8989.5,"AC",PRM,$PIECE(LST(I),U)_";OR(100.21,",1))
if FND=0
SET FNDNO=1
+19 IF 'FND
IF $GET(FNDNO)
SET FND=0
End DoDot:1
IF FND'=""
QUIT FND
+20 ;Check location
+21 IF +$GET(LOC)
SET VAL=$$GET^XPAR("LOC.`"_+$GET(LOC),PRM)
IF VAL'=""
QUIT VAL
+22 ;Check Service
+23 SET VAL=$GET(^XTV(8989.5,"AC",PRM,+$$GET1^DIQ(200,DUZ,29,"I")_";DIC(49,",1))
IF VAL'=""
QUIT VAL
+24 ;Check Division and System
+25 SET VAL=$$GET^XPAR("DIV^SYS",PRM)
IF VAL'=""
QUIT VAL
+26 QUIT ""
+27 ;
DEFHELP ;Provide detailed help for setting default treating specialty
+1 NEW DEF,DEFTS,DEFTSNM
+2 IF $DATA(^ORD(100.5,DA(1),"TS","DEF"))
Begin DoDot:1
+3 SET DEF=$ORDER(^ORD(100.5,DA(1),"TS","DEF",1,0))
+4 ;Default is current entry
IF DEF=DA
QUIT
+5 SET DEFTS=$PIECE(^ORD(100.5,DA(1),"TS",DEF,0),U)
+6 SET DEFTSNM=$$GET1^DIQ(45.7,DEFTS_",",.01)
+7 WRITE !?5,"You may not set this treating specialty as the default because"
+8 WRITE !?5,DEFTSNM," is already set as the default."
+9 WRITE !?5,"If you would like to change the default you must first delete the",!?5,"default designation from the above mentioned treating specialty.",!
End DoDot:1
QUIT
+10 ;
+11 WRITE !?5,"Currently there is no default treating specialty set for this event.",!
+12 QUIT
+13 ;
EVENTLST ;Allow user to edit OREVNT COMMON LIST parameter and set a default for that list
+1 NEW DIC,X,Y,PRM,ORENT
+2 SET DIC=8989.51
SET DIC(0)="MX"
SET X="OREVNT COMMON LIST"
DO ^DIC
+3 ;Parameter doesn't exist
if Y=-1
QUIT
+4 SET PRM=Y
+5 DO GETENT^XPAREDIT(.ORENT,PRM)
+6 ;Nothing selected
if ORENT=""
QUIT
+7 ;edit selected entity
DO EDIT^XPAREDIT(ORENT,PRM)
+8 ;User ^ or timed out
if $GET(DUOUT)!($GET(DTOUT))
QUIT
+9 ;No value stored for entity don't ask for default
IF '$DATA(^XTV(8989.5,"AC",+PRM,ORENT))
QUIT
+10 DO SETDFLT(ORENT,PRM)
+11 QUIT
+12 ;
SETDFLT(ORENT,PRM) ;Set default for given list
+1 NEW DIC,Y,X,PRMD,DEF,I,J,DIR,FND,ORLST
+2 IF $GET(PRM)=""
SET DIC=8989.51
SET DIC(0)="MX"
SET X="OREVNT COMMON LIST"
DO ^DIC
if Y=-1
QUIT
SET PRM=Y
+3 SET DIC=8989.51
SET DIC(0)="MX"
SET X="OREVNT DEFAULT"
DO ^DIC
+4 ;Parameter doesn't exist
if Y=-1
QUIT
+5 SET PRMD=Y
+6 ;Nothing selected
IF $GET(ORENT)=""
DO GETENT^XPAREDIT(.ORENT,PRMD)
if ORENT=""
QUIT
+7 DO GETLST^XPAR(.ORLST,ORENT,+PRM)
+8 IF ORLST=0
WRITE !!,"No common list is defined for this entity and therefore a default",!,"may not be set. Create a common list first.",!
QUIT
+9 SET DEF=$$GET^XPAR(ORENT,+PRMD,,"B")
FOR I=1:1:ORLST
IF $PIECE(ORLST(I),U,2)=+DEF
SET FND=1
+10 ;Delete default if no longer in list
IF '$GET(FND)
SET DEF=""
DO EN^XPAR(ORENT,+PRMD,,"@")
+11 WRITE !!,$SELECT(DEF'="":"Current DEFAULT is "_$PIECE(DEF,U,2)_$SELECT($GET(^ORD(100.5,+DEF,1)):" (*INACTIVE*)",1:""),1:"No DEFAULT has been set yet.")
+12 WRITE !
FOR J=1:1:ORLST
WRITE !,J,") ",$PIECE(^ORD(100.5,$PIECE(ORLST(J),U,2),0),U),$SELECT($GET(^(1)):" (*INACTIVE*)",1:"")
+13 IF DEF'=""
SET ORLST=ORLST+1
WRITE !!,ORLST,") DELETE CURRENT DEFAULT"
+14 WRITE !
SET DIR(0)="NO^1:"_ORLST
SET DIR("A")="Select default release event"_$SELECT(DEF'="":" or delete current event",1:"")
DO ^DIR
+15 ;No selection made
IF 'Y
QUIT
+16 IF Y=ORLST&(DEF'="")
DO EN^XPAR(ORENT,+PRMD,,"@")
WRITE !,"Default deleted"
QUIT
+17 ;No inactive defaults can be set
IF $GET(^ORD(100.5,$PIECE(ORLST(Y),U,2),1))
WRITE !,"You cannot set an inactive event as the default."
QUIT
+18 ;write updated parameter
+19 DO EN^XPAR(ORENT,+PRMD,,"`"_$PIECE(ORLST(Y),"^",2))
+20 QUIT
+21 ;
GETLST(LST) ;Return common list and default event
+1 NEW I,FND,PRM,X,Y,DIC,TLST,ORCLST,ENT,EXP,STR
+2 SET DIC=8989.51
SET DIC(0)="MX"
SET X="OREVNT COMMON LIST"
DO ^DIC
+3 ;Parameter not found so quit
IF Y=-1
QUIT
+4 SET PRM=+Y
+5 ;Nothing defined at any level
DO ENVAL^XPAR(.ORCLST,PRM)
if ORCLST=0
QUIT
+6 ;Check USER level
+7 SET ENT=DUZ_";VA(200,"
IF $DATA(ORCLST(ENT))
DO RETLST
QUIT
+8 ;Check USER CLASS
+9 DO WHATIS^USRLM(DUZ,"TLST")
+10 IF $ORDER(TLST(0))'=""
Begin DoDot:1
+11 SET FND=0
+12 SET I=0
FOR
SET I=$ORDER(TLST(I))
if I=""!(FND)
QUIT
SET ENT=$PIECE(TLST(I),U)_";USR(8930,"
SET EXP=+$PIECE(TLST(I),U,5)
SET STR=+$PIECE(TLST(I),U,4)
IF 'EXP!(EXP'<DT)
IF 'STR!(STR'>DT)
IF $DATA(ORCLST(ENT))
DO RETLST
SET FND=1
End DoDot:1
IF FND
QUIT
+13 ;Check OE/RR Teams
+14 KILL TLST
+15 DO TEAMPR^ORQPTQ1(.TLST,DUZ)
+16 IF +$GET(TLST(1))
Begin DoDot:1
+17 SET FND=0
+18 SET I=0
FOR
SET I=$ORDER(TLST(I))
if I=""!(FND)
QUIT
SET ENT=$PIECE(TLST(I),U)_"OR(100.21,"
IF $DATA(ORCLST(ENT))
DO RETLST
SET FND=1
End DoDot:1
IF FND
QUIT
+19 ;Check location
+20 IF +$GET(LOC)
SET ENT=+LOC_";SC("
IF $DATA(ORCLST(ENT))
DO RETLST
QUIT
+21 ;Check Service
+22 SET ENT=$$GET1^DIQ(200,DUZ,29,"I")_";DIC(49,"
+23 IF $DATA(ORCLST(ENT))
DO RETLST
QUIT
+24 ;Check Division
+25 SET ENT=DUZ(2)_";DIC(4,"
IF $DATA(ORCLST(ENT))
DO RETLST
QUIT
+26 QUIT
+27 ;
RETLST ;Sets up list for entity
+1 NEW DEF,Y,DIC,I,CNT,X
+2 SET DIC=8989.51
SET DIC(0)="MQ"
SET X="OREVNT DEFAULT"
DO ^DIC
+3 ;Stop if parameter doesn't exist
if 'Y
QUIT
+4 SET CNT=1
+5 SET DEF=$$GET^XPAR(ENT,+Y,,"B")
+6 SET I=0
FOR
SET I=$ORDER(ORCLST(ENT,I))
if '+I
QUIT
IF '$GET(^ORD(100.5,ORCLST(ENT,I),1))&('$DATA(^ORD(100.5,"DAD",ORCLST(ENT,I))))
SET LST(CNT)=ORCLST(ENT,I)
if ORCLST(ENT,I)=+DEF
SET $PIECE(LST(CNT),U,2)=1
SET CNT=CNT+1
+7 QUIT
