CRHD5 ; CAIRO/CLC - MISC ROUTINE FOR CAIRO HAND-OFF TOOL ;20-Mar-2008 13:28;CLC
;;1.0;CRHD;****;Jan 28, 2008;Build 19
;=================================================================
SRV(CRHDY) ; RETURN LIST OF SERVICES/SECTIONS
N CRHDI,CRHDIEN,CRHDNAME
S CRHDI=1,CRHDNAME=""
F S CRHDNAME=$O(^DIC(49,"B",CRHDNAME)) Q:CRHDNAME="" S CRHDIEN=$O(^(CRHDNAME,0)) D
. S CRHDY(CRHDI)=CRHDIEN_"^"_CRHDNAME,CRHDI=CRHDI+1
Q
DIV(CRHDY) ; RETURN LIST OF INSTITUTIONS
N CRHDI,CRHDIEN,CRHDNAME,CRHDIVST,CRHDINA
S CRHDI=1,CRHDNAME=""
F S CRHDNAME=$O(^DIC(4,"B",CRHDNAME)) Q:CRHDNAME="" S CRHDIEN=$O(^(CRHDNAME,0)) D
.S CRHDINA=$$GET1^DIQ(4,CRHDIEN_",",101,"I")
.S CRHDIVST=$$GET1^DIQ(4,CRHDIEN_",",11,"I")
.I 'CRHDINA S CRHDY(CRHDI)=CRHDIEN_"^"_CRHDNAME,CRHDI=CRHDI+1
Q
SET(CRHDENT,CRHDP,CRHDS,CRHDVAL) ;Set the parameter
;D PUT^XPAR("DIV.`583","CRHD DNR ORDER TITLE",2,"Patient DNR Orders")
;CRHDENT=entity
;CRHDP=Parameter name
;CRHDS=Sequence (count)
;CRHDVAL=parameter value
N CRHDERR,CRHDFG
;
S CRHDFG=1
D PUT^XPAR(CRHDENT,CRHDP,+CRHDS,CRHDVAL,.CRHDERR)
I CRHDERR>0 S CRHDFG=0
Q CRHDFG
DEL(CRHDENT,CRHDP,CRHDS) ;Delete a parameter value
N CRHDERR,CRHDFG
S CRHDFG=1
D DEL^XPAR(CRHDENT,CRHDP,CRHDS,.CRHDERR)
I CRHDERR>0 S CRHDFG=0
Q CRHDFG
GET(CRHDRTN,CRHDENT,CRHDP) ;Get parameters from the parameter file
D GETLST^XPAR(.CRHDRTN,CRHDENT,CRHDP,"E")
Q
DELALL(CRHDENT,CRHDP) ;Delete all instances
N CRHDERR,CRHDFG
S CRHDFG=1
D NDEL^XPAR(CRHDENT,CRHDP,.CRHDERR)
I CRHDERR>0 S CRHDFG=0
Q CRHDFG
USERDIV(CRHDRTN,CRHDDUZ) ;
K CRHDRTN
N CRHDX,CRHDR,CRHDC
S CRHDC=0
D DIV4^XUSER(.CRHDR,CRHDDUZ)
S CRHDX=0
F S CRHDX=$O(CRHDR(CRHDX)) Q:'CRHDX!($D(CRHDRTN(1))) D
.I CRHDR(CRHDX)=1 S CRHDC=CRHDC+1,CRHDRTN(CRHDC)=CRHDX_"^"_$P($G(^DIC(4,+CRHDX,0)),"^",1)_"^1" K CRHDR(CRHDX)
S CRHDX=0
F S CRHDX=$O(CRHDR(CRHDX)) Q:'CRHDX D
.S CRHDC=CRHDC+1
.S CRHDRTN(CRHDC)=CRHDX_"^"_$P($G(^DIC(4,+CRHDX,0)),"^",1)_"^0"
Q
DELPREF(CRHDRTN,CRHDE) ;delete a preference
N Y,X,CRHDE1,CRHDE2,CRHDE3,CRHDE4,CRHDE5,DA,DR,DIE,CRHDL
N CRHDPN
S CRHDRTN(1)=0
S CRHDE1=+CRHDE
S CRHDE2=$P(CRHDE,"^",2)
S CRHDL=$L(CRHDE,"^")
S CRHDE3=$P(CRHDE,"^",CRHDL)
S CRHDE4="DIV.`"_$P($P(CRHDE,"^",CRHDL),"-",2)
S CRHDE5=CRHDE1_$S(CRHDE3="USR":";VA(200,",CRHDE3="OTL":";OR(100.21,",CRHDE3="DIV":";DIC(4,",CRHDE3="SRV":";DIC(49,",1:"")
I CRHDE5'="" S DA=$O(^CRHD(183,"B",CRHDE5,0))
I DA D
.K ^CRHD(183,DA)
.K ^CRHD(183,"B",CRHDE5)
.K ^CRHD(183,"AC",+CRHDE5)
.;S DIE=183,DR=".01///@" D ^DIE
.I '$D(^CRHD(183,"B",CRHDE5)) S CRHDRTN(1)=1
.S CRHDENT=CRHDE3_".`"_CRHDE1
.I CRHDE3="DIV" S CRHDPN(1)="CRHD DNR ORDERABLE ITEMS",CRHDPN(2)="CRHD DNR ORDER TITLE"
.S CRHDX=0
.F S CRHDX=$O(CRHDPN(CRHDX)) Q:'CRHDX D
..D GETLST^XPAR(.CRHDOLST,CRHDENT,CRHDPN(CRHDX),"I")
..I $G(CRHDOLST) S CRHDFG=$$DELALL^CRHD5(CRHDENT,CRHDPN(CRHDX)) K CRHDOLST
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HCRHD5 2930 printed Oct 16, 2024@18:38:26 Page 2
CRHD5 ; CAIRO/CLC - MISC ROUTINE FOR CAIRO HAND-OFF TOOL ;20-Mar-2008 13:28;CLC
+1 ;;1.0;CRHD;****;Jan 28, 2008;Build 19
+2 ;=================================================================
SRV(CRHDY) ; RETURN LIST OF SERVICES/SECTIONS
+1 NEW CRHDI,CRHDIEN,CRHDNAME
+2 SET CRHDI=1
SET CRHDNAME=""
+3 FOR
SET CRHDNAME=$ORDER(^DIC(49,"B",CRHDNAME))
if CRHDNAME=""
QUIT
SET CRHDIEN=$ORDER(^(CRHDNAME,0))
Begin DoDot:1
+4 SET CRHDY(CRHDI)=CRHDIEN_"^"_CRHDNAME
SET CRHDI=CRHDI+1
End DoDot:1
+5 QUIT
DIV(CRHDY) ; RETURN LIST OF INSTITUTIONS
+1 NEW CRHDI,CRHDIEN,CRHDNAME,CRHDIVST,CRHDINA
+2 SET CRHDI=1
SET CRHDNAME=""
+3 FOR
SET CRHDNAME=$ORDER(^DIC(4,"B",CRHDNAME))
if CRHDNAME=""
QUIT
SET CRHDIEN=$ORDER(^(CRHDNAME,0))
Begin DoDot:1
+4 SET CRHDINA=$$GET1^DIQ(4,CRHDIEN_",",101,"I")
+5 SET CRHDIVST=$$GET1^DIQ(4,CRHDIEN_",",11,"I")
+6 IF 'CRHDINA
SET CRHDY(CRHDI)=CRHDIEN_"^"_CRHDNAME
SET CRHDI=CRHDI+1
End DoDot:1
+7 QUIT
SET(CRHDENT,CRHDP,CRHDS,CRHDVAL) ;Set the parameter
+1 ;D PUT^XPAR("DIV.`583","CRHD DNR ORDER TITLE",2,"Patient DNR Orders")
+2 ;CRHDENT=entity
+3 ;CRHDP=Parameter name
+4 ;CRHDS=Sequence (count)
+5 ;CRHDVAL=parameter value
+6 NEW CRHDERR,CRHDFG
+7 ;
+8 SET CRHDFG=1
+9 DO PUT^XPAR(CRHDENT,CRHDP,+CRHDS,CRHDVAL,.CRHDERR)
+10 IF CRHDERR>0
SET CRHDFG=0
+11 QUIT CRHDFG
DEL(CRHDENT,CRHDP,CRHDS) ;Delete a parameter value
+1 NEW CRHDERR,CRHDFG
+2 SET CRHDFG=1
+3 DO DEL^XPAR(CRHDENT,CRHDP,CRHDS,.CRHDERR)
+4 IF CRHDERR>0
SET CRHDFG=0
+5 QUIT CRHDFG
GET(CRHDRTN,CRHDENT,CRHDP) ;Get parameters from the parameter file
+1 DO GETLST^XPAR(.CRHDRTN,CRHDENT,CRHDP,"E")
+2 QUIT
DELALL(CRHDENT,CRHDP) ;Delete all instances
+1 NEW CRHDERR,CRHDFG
+2 SET CRHDFG=1
+3 DO NDEL^XPAR(CRHDENT,CRHDP,.CRHDERR)
+4 IF CRHDERR>0
SET CRHDFG=0
+5 QUIT CRHDFG
USERDIV(CRHDRTN,CRHDDUZ) ;
+1 KILL CRHDRTN
+2 NEW CRHDX,CRHDR,CRHDC
+3 SET CRHDC=0
+4 DO DIV4^XUSER(.CRHDR,CRHDDUZ)
+5 SET CRHDX=0
+6 FOR
SET CRHDX=$ORDER(CRHDR(CRHDX))
if 'CRHDX!($DATA(CRHDRTN(1)))
QUIT
Begin DoDot:1
+7 IF CRHDR(CRHDX)=1
SET CRHDC=CRHDC+1
SET CRHDRTN(CRHDC)=CRHDX_"^"_$PIECE($GET(^DIC(4,+CRHDX,0)),"^",1)_"^1"
KILL CRHDR(CRHDX)
End DoDot:1
+8 SET CRHDX=0
+9 FOR
SET CRHDX=$ORDER(CRHDR(CRHDX))
if 'CRHDX
QUIT
Begin DoDot:1
+10 SET CRHDC=CRHDC+1
+11 SET CRHDRTN(CRHDC)=CRHDX_"^"_$PIECE($GET(^DIC(4,+CRHDX,0)),"^",1)_"^0"
End DoDot:1
+12 QUIT
DELPREF(CRHDRTN,CRHDE) ;delete a preference
+1 NEW Y,X,CRHDE1,CRHDE2,CRHDE3,CRHDE4,CRHDE5,DA,DR,DIE,CRHDL
+2 NEW CRHDPN
+3 SET CRHDRTN(1)=0
+4 SET CRHDE1=+CRHDE
+5 SET CRHDE2=$PIECE(CRHDE,"^",2)
+6 SET CRHDL=$LENGTH(CRHDE,"^")
+7 SET CRHDE3=$PIECE(CRHDE,"^",CRHDL)
+8 SET CRHDE4="DIV.`"_$PIECE($PIECE(CRHDE,"^",CRHDL),"-",2)
+9 SET CRHDE5=CRHDE1_$SELECT(CRHDE3="USR":";VA(200,",CRHDE3="OTL":";OR(100.21,",CRHDE3="DIV":";DIC(4,",CRHDE3="SRV":";DIC(49,",1:"")
+10 IF CRHDE5'=""
SET DA=$ORDER(^CRHD(183,"B",CRHDE5,0))
+11 IF DA
Begin DoDot:1
+12 KILL ^CRHD(183,DA)
+13 KILL ^CRHD(183,"B",CRHDE5)
+14 KILL ^CRHD(183,"AC",+CRHDE5)
+15 ;S DIE=183,DR=".01///@" D ^DIE
+16 IF '$DATA(^CRHD(183,"B",CRHDE5))
SET CRHDRTN(1)=1
+17 SET CRHDENT=CRHDE3_".`"_CRHDE1
+18 IF CRHDE3="DIV"
SET CRHDPN(1)="CRHD DNR ORDERABLE ITEMS"
SET CRHDPN(2)="CRHD DNR ORDER TITLE"
+19 SET CRHDX=0
+20 FOR
SET CRHDX=$ORDER(CRHDPN(CRHDX))
if 'CRHDX
QUIT
Begin DoDot:2
+21 DO GETLST^XPAR(.CRHDOLST,CRHDENT,CRHDPN(CRHDX),"I")
+22 IF $GET(CRHDOLST)
SET CRHDFG=$$DELALL^CRHD5(CRHDENT,CRHDPN(CRHDX))
KILL CRHDOLST
End DoDot:2
End DoDot:1
+23 QUIT
