CRHD6 ; CAIRO/CLC - MISC ROUTINE FOR CAIRO HAND-OFF TOOL ;06-Aug-2018 15:00;
;;1.0;CRHD;**8**;Jan 28, 2008;Build 14
;=================================================================
GETP(CRHDRTN,CRHDE) ;
N CRHDPAR,Y,CRHDX,CRHDCT,CRHDMN,CRHDP,CRHDE1,CRHDE2,CRHDE3,CRHDE4
N CRHDX2,CRHDRSL,CRHDL,CRHDXCT,CRHDTRSL,CRHDEX,CRHDEE,CRHDXY
S Y=-1
S CRHDE1=+CRHDE ;internal entry number to file
S CRHDE2=$P(CRHDE,"^",2) ;name
S CRHDE3=$P(CRHDE,"^",3) ;types
; USR - New Person
; OTL - OE/RR Team
; SRV - Service/Section
; DIV-Institution;
;
S CRHDCT=0
S CRHDL=$L(CRHDE,"^")
S CRHDE4="DIV.`"_$P($P(CRHDE,"^",CRHDL),"-",2) ;User Sign in Division
I $P(CRHDE4,"`",2)="" D USERDIV^CRHD5(.CRHDEE,DUZ) S CRHDE4="DIV.`"_$G(CRHDEE(1))
S CRHDE3=$P($P(CRHDE,"^",CRHDL),"-",1)
S CRHDPAR=CRHDE3_".`"_CRHDE1
I CRHDPAR'="" D LOOKUP^XPAREDIT(CRHDPAR,183)
I Y>-1 D
.S CRHDMN=+Y
.S CRHDP=0
.F S CRHDP=$O(^CRHD(183,CRHDMN,1,CRHDP)) Q:'CRHDP D
..S CRHDCT=CRHDCT+1
..I $P($G(^CRHD(183,CRHDMN,1,CRHDP,0)),"^",2)="" D
...S CRHDX2=0 F S CRHDX2=$O(^CRHD(183,CRHDMN,1,CRHDP,1,CRHDX2)) Q:'CRHDX2 D
....S CRHDRTN(CRHDCT)=$P($G(^CRHD(183,CRHDMN,1,CRHDP,0)),"^",1)_"^"_$G(^CRHD(183,CRHDMN,1,CRHDP,1,CRHDX2,0))
....S CRHDCT=CRHDCT+1
..E S CRHDRTN(CRHDCT)=$G(^CRHD(183,CRHDMN,1,CRHDP,0))
;get Temp fields expiration days
S CRHDEX=$$GET^XPAR(CRHDE4,"CRHD TEMP FLD EXPIRE",1,"I")
I 'CRHDEX S CRHDEX=2
S CRHDCT=CRHDCT+1,CRHDRTN(CRHDCT)="TEMP_FLD_EXPIRE"_"^"_CRHDEX
;get dnr title and/or text
K CRHDRSL D DNRPARM^CRHDDR(.CRHDRSL,DUZ,$P($P(CRHDE,"^",CRHDL),"-",2)) D
.I $D(CRHDRSL) D
..S (CRHDXCT,CRHDXY)=0 F S CRHDXY=$O(CRHDRSL(CRHDXY)) Q:'CRHDXY D
...S CRHDXCT=CRHDXCT+1,CRHDTRSL(CRHDXCT)=CRHDXY_"^"_$P($G(^ORD(101.43,+CRHDXY,0)),"^",1)
.I $D(CRHDTRSL) K CRHDRSL M CRHDRSL=CRHDTRSL K CRHDTRSL
I $D(CRHDRSL) D RTNLST("DNR_Titles") K CRHDRSL
D GET^CRHD5(.CRHDRSL,CRHDE4,"CRHD DNR ORDER TITLE")
I $D(CRHDRSL) D RTNLST("DNR_Text")
Q
RTNLST(CRHDTT) ;
I $D(CRHDRSL) D
.S CRHDX=0
.I CRHDTT["DNR_Titles" F S CRHDX=$O(CRHDRSL(CRHDX)) Q:'CRHDX S CRHDCT=CRHDCT+1,CRHDRTN(CRHDCT)=CRHDTT_"^"_CRHDRSL(CRHDX)
.E F S CRHDX=$O(CRHDRSL(CRHDX)) Q:'CRHDX S CRHDCT=CRHDCT+1,CRHDRTN(CRHDCT)=CRHDTT_"^"_$P(CRHDRSL(CRHDX),"^",2)
Q
;
SAVEP(CRHDRTN,CRHDE,CRHDPN,CRHDV,CRHDVAL) ;
N CRHDENT,CRHDX,CRHDX1,CRHDOLST,CRHDFG,CRHDL
S CRHDRTN(0)=1
I CRHDE="" S CRHDRTN(0)=0_"^Entity data not valid" Q
S CRHDL=$L(CRHDE,"^")
I +CRHDE S CRHDENT=$P($P(CRHDE,"^",CRHDL),"-",1)_".`"_+CRHDE
I CRHDPN="" S CRHDPN="CRHD DNR ORDER TITLE"
;get all Instances of a Parameter
D GETLST^XPAR(.CRHDOLST,CRHDENT,CRHDPN,"I")
I $D(CRHDOLST) S CRHDFG=$$DELALL^CRHD5(CRHDENT,CRHDPN)
I $D(CRHDVAL) D
.S CRHDX=0,CRHDCT=0
.F S CRHDX=$O(CRHDVAL(CRHDX)) Q:'CRHDX D
..S CRHDCT=CRHDCT+1
..D SET^CRHD5(CRHDENT,CRHDPN,CRHDCT,CRHDVAL(CRHDX))
Q
SAVEP2(CRHDRTN,CRHDE,CRHDPN,CRHDV,CRHDVAL) ;
N CRHDENT,CRHDX,CRHDX1,CRHDOLST,CRHDFG,CRHDL
S CRHDRTN(0)=1
I CRHDE="" S CRHDRTN(0)=0_"^Entity data not valid" Q
S CRHDL=$L(CRHDE,"^")
I +CRHDE S CRHDENT=$P($P(CRHDE,"^",CRHDL),"-",1)_".`"_+CRHDE
I CRHDPN="" S CRHDRTN(0)=0_"^Parameter name not valid" Q ;S PN="CRHD DNR ORDER TITLE"
I CRHDV=""&('$D(CRHDVAL)) S CRHDFG=$$DELALL^CRHD5(CRHDENT,CRHDPN) S CRHDRTN(0)=1 Q
;get all Instances of a Parameter
D GETLST^XPAR(.CRHDOLST,CRHDENT,CRHDPN,"I")
I $G(CRHDOLST) S CRHDFG=$$DELALL^CRHD5(CRHDENT,CRHDPN) K CRHDOLST
I $D(CRHDVAL) D
.S CRHDX=0,CRHDCT=0
.F S CRHDX=$O(CRHDVAL(CRHDX)) Q:'CRHDX D
..S CRHDCT=CRHDCT+1
..I CRHDVAL(CRHDX)'="" D
...I CRHDVAL(CRHDX)?1N.E S CRHDVAL(CRHDX)=+CRHDVAL(CRHDX)
...I CRHDVAL(CRHDX)?1A.E S CRHDVAL(CRHDX)=$P(CRHDVAL(CRHDX),"^",1)
..D SET^CRHD5(CRHDENT,CRHDPN,CRHDCT,CRHDVAL(CRHDX))
Q
GETPAR2(CRHDRTN,CRHDE,CRHDPN) ;
;Get XPAR parameter values
N CRHDENT,CRHDX,CRHDX1,CRHDL,CRHDOLST,CRHDPNUM,CRHDFMT,CRHDFG
N CRHDI
S CRHDRTN(0)=1
S CRHDFMT="I"
I CRHDE="" S CRHDRTN(0)=0_"^Entity data not valid" Q
S CRHDL=$L(CRHDE,"^")
I +CRHDE S CRHDENT=$P($P(CRHDE,"^",CRHDL),"-",1)_".`"_+CRHDE
I CRHDPN="" S CRHDRTN(0)=0_"^Parameter name not valid" Q ;S PN="CRHD DNR ORDER TITLE"
;get format code
S CRHDPNUM=$O(^XTV(8989.51,"B",CRHDPN,0))
I CRHDPNUM D
.S CRHDFMT=$S(($P($G(^XTV(8989.51,CRHDPNUM,1)),"^",1)="F")!($P($G(^XTV(8989.51,CRHDPNUM,1)),"^",6)="F"):"E",1:"B")
;get all Instances of a Parameter
D GETLST^XPAR(.CRHDOLST,CRHDENT,CRHDPN,CRHDFMT)
I CRHDFMT="B" D
.K CRHDRTN
.S CRHDI=0
.F S CRHDI=$O(CRHDOLST(CRHDI)) Q:'CRHDI S:$G(CRHDOLST(CRHDI,"V"))'="" CRHDRTN(CRHDI)=$G(CRHDOLST(CRHDI,"V"))
E K CRHDRTN D
.S CRHDI=0
.F S CRHDI=$O(CRHDOLST(CRHDI)) Q:'CRHDI S CRHDRTN(CRHDI)=$P(CRHDOLST(CRHDI),"^",2)
Q
PARAM(VAL,APARAM) ; return a parameter value for a user
; call assumes current user, default entities, single instance
S VAL=$$GET^XPAR("ALL",APARAM,1,"I")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HCRHD6 5142 printed Dec 13, 2024@02:37:50 Page 2
CRHD6 ; CAIRO/CLC - MISC ROUTINE FOR CAIRO HAND-OFF TOOL ;06-Aug-2018 15:00;
+1 ;;1.0;CRHD;**8**;Jan 28, 2008;Build 14
+2 ;=================================================================
GETP(CRHDRTN,CRHDE) ;
+1 NEW CRHDPAR,Y,CRHDX,CRHDCT,CRHDMN,CRHDP,CRHDE1,CRHDE2,CRHDE3,CRHDE4
+2 NEW CRHDX2,CRHDRSL,CRHDL,CRHDXCT,CRHDTRSL,CRHDEX,CRHDEE,CRHDXY
+3 SET Y=-1
+4 ;internal entry number to file
SET CRHDE1=+CRHDE
+5 ;name
SET CRHDE2=$PIECE(CRHDE,"^",2)
+6 ;types
SET CRHDE3=$PIECE(CRHDE,"^",3)
+7 ; USR - New Person
+8 ; OTL - OE/RR Team
+9 ; SRV - Service/Section
+10 ; DIV-Institution;
+11 ;
+12 SET CRHDCT=0
+13 SET CRHDL=$LENGTH(CRHDE,"^")
+14 ;User Sign in Division
SET CRHDE4="DIV.`"_$PIECE($PIECE(CRHDE,"^",CRHDL),"-",2)
+15 IF $PIECE(CRHDE4,"`",2)=""
DO USERDIV^CRHD5(.CRHDEE,DUZ)
SET CRHDE4="DIV.`"_$GET(CRHDEE(1))
+16 SET CRHDE3=$PIECE($PIECE(CRHDE,"^",CRHDL),"-",1)
+17 SET CRHDPAR=CRHDE3_".`"_CRHDE1
+18 IF CRHDPAR'=""
DO LOOKUP^XPAREDIT(CRHDPAR,183)
+19 IF Y>-1
Begin DoDot:1
+20 SET CRHDMN=+Y
+21 SET CRHDP=0
+22 FOR
SET CRHDP=$ORDER(^CRHD(183,CRHDMN,1,CRHDP))
if 'CRHDP
QUIT
Begin DoDot:2
+23 SET CRHDCT=CRHDCT+1
+24 IF $PIECE($GET(^CRHD(183,CRHDMN,1,CRHDP,0)),"^",2)=""
Begin DoDot:3
+25 SET CRHDX2=0
FOR
SET CRHDX2=$ORDER(^CRHD(183,CRHDMN,1,CRHDP,1,CRHDX2))
if 'CRHDX2
QUIT
Begin DoDot:4
+26 SET CRHDRTN(CRHDCT)=$PIECE($GET(^CRHD(183,CRHDMN,1,CRHDP,0)),"^",1)_"^"_$GET(^CRHD(183,CRHDMN,1,CRHDP,1,CRHDX2,0))
+27 SET CRHDCT=CRHDCT+1
End DoDot:4
End DoDot:3
+28 IF '$TEST
SET CRHDRTN(CRHDCT)=$GET(^CRHD(183,CRHDMN,1,CRHDP,0))
End DoDot:2
End DoDot:1
+29 ;get Temp fields expiration days
+30 SET CRHDEX=$$GET^XPAR(CRHDE4,"CRHD TEMP FLD EXPIRE",1,"I")
+31 IF 'CRHDEX
SET CRHDEX=2
+32 SET CRHDCT=CRHDCT+1
SET CRHDRTN(CRHDCT)="TEMP_FLD_EXPIRE"_"^"_CRHDEX
+33 ;get dnr title and/or text
+34 KILL CRHDRSL
DO DNRPARM^CRHDDR(.CRHDRSL,DUZ,$PIECE($PIECE(CRHDE,"^",CRHDL),"-",2))
Begin DoDot:1
+35 IF $DATA(CRHDRSL)
Begin DoDot:2
+36 SET (CRHDXCT,CRHDXY)=0
FOR
SET CRHDXY=$ORDER(CRHDRSL(CRHDXY))
if 'CRHDXY
QUIT
Begin DoDot:3
+37 SET CRHDXCT=CRHDXCT+1
SET CRHDTRSL(CRHDXCT)=CRHDXY_"^"_$PIECE($GET(^ORD(101.43,+CRHDXY,0)),"^",1)
End DoDot:3
End DoDot:2
+38 IF $DATA(CRHDTRSL)
KILL CRHDRSL
MERGE CRHDRSL=CRHDTRSL
KILL CRHDTRSL
End DoDot:1
+39 IF $DATA(CRHDRSL)
DO RTNLST("DNR_Titles")
KILL CRHDRSL
+40 DO GET^CRHD5(.CRHDRSL,CRHDE4,"CRHD DNR ORDER TITLE")
+41 IF $DATA(CRHDRSL)
DO RTNLST("DNR_Text")
+42 QUIT
RTNLST(CRHDTT) ;
+1 IF $DATA(CRHDRSL)
Begin DoDot:1
+2 SET CRHDX=0
+3 IF CRHDTT["DNR_Titles"
FOR
SET CRHDX=$ORDER(CRHDRSL(CRHDX))
if 'CRHDX
QUIT
SET CRHDCT=CRHDCT+1
SET CRHDRTN(CRHDCT)=CRHDTT_"^"_CRHDRSL(CRHDX)
+4 IF '$TEST
FOR
SET CRHDX=$ORDER(CRHDRSL(CRHDX))
if 'CRHDX
QUIT
SET CRHDCT=CRHDCT+1
SET CRHDRTN(CRHDCT)=CRHDTT_"^"_$PIECE(CRHDRSL(CRHDX),"^",2)
End DoDot:1
+5 QUIT
+6 ;
SAVEP(CRHDRTN,CRHDE,CRHDPN,CRHDV,CRHDVAL) ;
+1 NEW CRHDENT,CRHDX,CRHDX1,CRHDOLST,CRHDFG,CRHDL
+2 SET CRHDRTN(0)=1
+3 IF CRHDE=""
SET CRHDRTN(0)=0_"^Entity data not valid"
QUIT
+4 SET CRHDL=$LENGTH(CRHDE,"^")
+5 IF +CRHDE
SET CRHDENT=$PIECE($PIECE(CRHDE,"^",CRHDL),"-",1)_".`"_+CRHDE
+6 IF CRHDPN=""
SET CRHDPN="CRHD DNR ORDER TITLE"
+7 ;get all Instances of a Parameter
+8 DO GETLST^XPAR(.CRHDOLST,CRHDENT,CRHDPN,"I")
+9 IF $DATA(CRHDOLST)
SET CRHDFG=$$DELALL^CRHD5(CRHDENT,CRHDPN)
+10 IF $DATA(CRHDVAL)
Begin DoDot:1
+11 SET CRHDX=0
SET CRHDCT=0
+12 FOR
SET CRHDX=$ORDER(CRHDVAL(CRHDX))
if 'CRHDX
QUIT
Begin DoDot:2
+13 SET CRHDCT=CRHDCT+1
+14 DO SET^CRHD5(CRHDENT,CRHDPN,CRHDCT,CRHDVAL(CRHDX))
End DoDot:2
End DoDot:1
+15 QUIT
SAVEP2(CRHDRTN,CRHDE,CRHDPN,CRHDV,CRHDVAL) ;
+1 NEW CRHDENT,CRHDX,CRHDX1,CRHDOLST,CRHDFG,CRHDL
+2 SET CRHDRTN(0)=1
+3 IF CRHDE=""
SET CRHDRTN(0)=0_"^Entity data not valid"
QUIT
+4 SET CRHDL=$LENGTH(CRHDE,"^")
+5 IF +CRHDE
SET CRHDENT=$PIECE($PIECE(CRHDE,"^",CRHDL),"-",1)_".`"_+CRHDE
+6 ;S PN="CRHD DNR ORDER TITLE"
IF CRHDPN=""
SET CRHDRTN(0)=0_"^Parameter name not valid"
QUIT
+7 IF CRHDV=""&('$DATA(CRHDVAL))
SET CRHDFG=$$DELALL^CRHD5(CRHDENT,CRHDPN)
SET CRHDRTN(0)=1
QUIT
+8 ;get all Instances of a Parameter
+9 DO GETLST^XPAR(.CRHDOLST,CRHDENT,CRHDPN,"I")
+10 IF $GET(CRHDOLST)
SET CRHDFG=$$DELALL^CRHD5(CRHDENT,CRHDPN)
KILL CRHDOLST
+11 IF $DATA(CRHDVAL)
Begin DoDot:1
+12 SET CRHDX=0
SET CRHDCT=0
+13 FOR
SET CRHDX=$ORDER(CRHDVAL(CRHDX))
if 'CRHDX
QUIT
Begin DoDot:2
+14 SET CRHDCT=CRHDCT+1
+15 IF CRHDVAL(CRHDX)'=""
Begin DoDot:3
+16 IF CRHDVAL(CRHDX)?1N.E
SET CRHDVAL(CRHDX)=+CRHDVAL(CRHDX)
+17 IF CRHDVAL(CRHDX)?1A.E
SET CRHDVAL(CRHDX)=$PIECE(CRHDVAL(CRHDX),"^",1)
End DoDot:3
+18 DO SET^CRHD5(CRHDENT,CRHDPN,CRHDCT,CRHDVAL(CRHDX))
End DoDot:2
End DoDot:1
+19 QUIT
GETPAR2(CRHDRTN,CRHDE,CRHDPN) ;
+1 ;Get XPAR parameter values
+2 NEW CRHDENT,CRHDX,CRHDX1,CRHDL,CRHDOLST,CRHDPNUM,CRHDFMT,CRHDFG
+3 NEW CRHDI
+4 SET CRHDRTN(0)=1
+5 SET CRHDFMT="I"
+6 IF CRHDE=""
SET CRHDRTN(0)=0_"^Entity data not valid"
QUIT
+7 SET CRHDL=$LENGTH(CRHDE,"^")
+8 IF +CRHDE
SET CRHDENT=$PIECE($PIECE(CRHDE,"^",CRHDL),"-",1)_".`"_+CRHDE
+9 ;S PN="CRHD DNR ORDER TITLE"
IF CRHDPN=""
SET CRHDRTN(0)=0_"^Parameter name not valid"
QUIT
+10 ;get format code
+11 SET CRHDPNUM=$ORDER(^XTV(8989.51,"B",CRHDPN,0))
+12 IF CRHDPNUM
Begin DoDot:1
+13 SET CRHDFMT=$SELECT(($PIECE($GET(^XTV(8989.51,CRHDPNUM,1)),"^",1)="F")!($PIECE($GET(^XTV(8989.51,CRHDPNUM,1)),"^",6)="F"):"E",1:"B")
End DoDot:1
+14 ;get all Instances of a Parameter
+15 DO GETLST^XPAR(.CRHDOLST,CRHDENT,CRHDPN,CRHDFMT)
+16 IF CRHDFMT="B"
Begin DoDot:1
+17 KILL CRHDRTN
+18 SET CRHDI=0
+19 FOR
SET CRHDI=$ORDER(CRHDOLST(CRHDI))
if 'CRHDI
QUIT
if $GET(CRHDOLST(CRHDI,"V"))'=""
SET CRHDRTN(CRHDI)=$GET(CRHDOLST(CRHDI,"V"))
End DoDot:1
+20 IF '$TEST
KILL CRHDRTN
Begin DoDot:1
+21 SET CRHDI=0
+22 FOR
SET CRHDI=$ORDER(CRHDOLST(CRHDI))
if 'CRHDI
QUIT
SET CRHDRTN(CRHDI)=$PIECE(CRHDOLST(CRHDI),"^",2)
End DoDot:1
+23 QUIT
PARAM(VAL,APARAM) ; return a parameter value for a user
+1 ; call assumes current user, default entities, single instance
+2 SET VAL=$$GET^XPAR("ALL",APARAM,1,"I")
+3 QUIT
