CRHD4 ; CAIRO/CLC - GET USERS PARAMETERS ;4/22/08 12:52
;;1.0;CRHD;****;Jan 28, 2008;Build 19
;=================================================================
GETALLP(CRHDRTN,CRHDUSR,CRHDDIV,CRHDPLEV) ;get all of the users parameters
N X,X1,X2,CRHDCT,CRHDDOFG,CRHDMN,CRHDP,CRHDRSL,I,CRHDAX
N CRHDL,CRHDVPTR,CRHDPN
K CRHDRTN
S CRHDVPTR("USR")=";VA(200," ;NEW PERSON
S CRHDVPTR("OTL")=";OR(100.21," ;OE/RR TEAM
S CRHDVPTR("SRV")=";DIC(49," ;SERVICE/SERVICE
S CRHDVPTR("DIV")=";DIC(4," ;INSTITUTION
S CRHDVPTR("TS")=";DIC(45.7," ;TREATING SPECIALTY
S CRHDVPTR("LOC")=";SC(" ;HOSPITAL LOCATION
S CRHDVPTR("SD")=";SCTM(404.51," ;SD TEAM
S CRHDAX=+$G(CRHDPLEV)
S CRHDL=$L($G(CRHDPLEV),"^")
I CRHDAX D
.S CRHDAX=CRHDAX_$G(CRHDVPTR($P(CRHDPLEV,"^",CRHDL)))
.S CRHDDOFG=$O(^CRHD(183,"B",CRHDAX,0))
I $G(CRHDPLEV)="" S CRHDDOFG=$$GETPLEV(CRHDUSR,CRHDDIV,0)
I CRHDDOFG>0 D
.I CRHDDOFG["VA(200" D USRSET(.CRHDRSL,CRHDDOFG)
.I $D(CRHDRSL) S CRHDDOFG=$$GETPLEV(CRHDUSR,CRHDDIV,1)
.S CRHDMN=+CRHDDOFG
.S (CRHDP,CRHDCT)=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 X2=0 F S X2=$O(^CRHD(183,CRHDMN,1,CRHDP,1,X2)) Q:'X2 D
....I $D(CRHDRSL($P($G(^CRHD(183,CRHDMN,1,CRHDP,0)),"^",1))) Q
....;I $D(CRHDRSL("STUDENT")) Q
....S CRHDRTN(CRHDCT)=$P($G(^CRHD(183,CRHDMN,1,CRHDP,0)),"^",1)_"^"_$G(^CRHD(183,CRHDMN,1,CRHDP,1,X2,0))
....S CRHDCT=CRHDCT+1
..E S CRHDRTN(CRHDCT)=$G(^CRHD(183,CRHDMN,1,CRHDP,0))
I $D(CRHDRSL) D
.S CRHDPN=""
.F S CRHDPN=$O(CRHDRSL(CRHDPN)) Q:CRHDPN="" D
..S CRHDX=0
..F S CRHDX=$O(CRHDRSL(CRHDPN,CRHDX)) Q:'CRHDX S CRHDCT=CRHDCT+1,CRHDRTN(CRHDCT)=CRHDRSL(CRHDPN,CRHDX)
Q
USRSET(CRHDLST,CRHDDA) ;
N CRHDFG,CRHDX,CRHDP0,CRHDCT,CRHDX1
S (CRHDX,CRHDFG,CRHDCT)=0
F S CRHDX=$O(^CRHD(183,+CRHDDA,1,CRHDX)) Q:'CRHDX D
.S CRHDP0=$G(^CRHD(183,+CRHDDA,1,CRHDX,0))
.I $P(CRHDP0,"^",2)="" D
..S CRHDX1=0
..F S CRHDX1=$O(^CRHD(183,+CRHDDA,1,CRHDX,1,CRHDX1)) Q:'CRHDX1 S CRHDCT=CRHDCT+1,CRHDLST(CRHDP0,CRHDCT)=$P(CRHDP0,"^",1)_"^"_$G(^CRHD(183,+CRHDDA,1,CRHDX,1,CRHDX1,0))
.E S CRHDCT=CRHDCT+1,CRHDLST($P(CRHDP0,"^",1),CRHDCT)=CRHDP0
Q
GETONEP(CRHDRTN,CRHDE,PNAME) ;Get one parameter from file 183
N CRHDPAR,Y,X,CRHDCT,CRHDMN,CRHDP,CRHDE1,CRHDE2,CRHDE3,CRHDE4
N CRHDX2,CRHDRSL,CRHDL,CRHDXCT,CRHDTRSL,CRHDEX,CRHDEE
S Y=-1
S CRHDE1=+CRHDE ;internal entry number to file
S CRHDE2=$P(CRHDE,"^",2) ;name
S CRHDE3=$P($P(CRHDE,"^",3),"-",1) ;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 CRHDPAR=CRHDE3_".`"_CRHDE1
I CRHDPAR'="" D LOOKUP^XPAREDIT(CRHDPAR,183)
I Y>-1 D
.S CRHDMN=+Y
.S CRHDP=$O(^CRHD(183,CRHDMN,1,"B",PNAME,0))
.Q:'CRHDP
.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 CRHDCT=CRHDCT+1,CRHDRTN(CRHDCT)=$G(^CRHD(183,CRHDMN,1,+CRHDP,1,CRHDX2,0))
.E S CRHDRTN(1)=$P($G(^CRHD(183,CRHDMN,1,+CRHDP,0)),"^",2)
Q
GETDNRT(CRHDRTN,CRHDUSR,CRHDDIV) ;get DNR Titles
K CRHDRTN
N CRHDDNR,CRHDX
D DNRPARM^CRHDDNR(.CRHDDNR,DUZ,CRHDDIV)
I $D(CRHDDNR) D
.S CRHDX=0 F S CRHDX=$O(CRHDDNR(CRHDX)) Q:'CRHDX S CRHDRTN(CRHDX)=$P(CRHDDNR(CRHDX),"^",2)
Q
SAVEPARM(CRHDRTN,CRHDLEV,CRHDPAR,CRHDVAL,CRHDTXT) ;save parameters
N Y,CRHDFN,CRHDFDA,CRHDERR,CRHDOUT,CRHDFILE,CRHDXX,CRHDUPY,CRHDUPZ
N CRHDIENS,CRHDFLAG,CRHDANS,CRHDVPTR,CRHDL,DIE,DR,DA,CRHDAX
S CRHDVPTR("USR")=";VA(200," ;NEW PERSON
S CRHDVPTR("OTL")=";OR(100.21," ;OE/RR TEAM
S CRHDVPTR("SRV")=";DIC(49," ;SERVICE/SERVICE
S CRHDVPTR("DIV")=";DIC(4," ;INSTITUTION
;S CRHDVPTR("TS")=";DIC(45.7," ;TREATING SPECIALTY
;S CRHDVPTR("LOC")=";SC(" ;HOSPITAL LOCATION
;S CRHDVPTR("SD")=";SCTM(404.51," ;SD TEAM
S CRHDFN=183 ;CRHD PARAMETER FILE NUMBER
B K CRHDRTN
S CRHDRTN(0)="0^NO DATA STORED"
I $D(CRHDTXT)&((CRHDPAR="")&(CRHDVAL="")) D SAVELIST(.CRHDRTN,.CRHDLEV,.CRHDTXT) Q
I CRHDPAR="" S CRHDRTN(0)="0^PARAMETER NAME MISSING" Q
S CRHDUPY=$$CHK(CRHDLEV)
S CRHDUPZ=$P(CRHDUPY,"^",2)
S CRHDAX=$P(CRHDUPY,"^",3)
S CRHDL=$L(CRHDLEV,"^")
I CRHDAX<1 S CRHDAX=+CRHDLEV_$G(CRHDVPTR($P(CRHDLEV,"^",CRHDL)))
I +CRHDAX S CRHDFDA(CRHDFN,CRHDUPZ,.01)=CRHDAX
I CRHDUPZ="+1," D
.D UPDATE^DIE("","CRHDFDA","CRHDOUT","CRHDERR")
.I '$D(CRHDERR) S CRHDUPZ=CRHDOUT(1)_",",CRHDRTN(0)=1
.K CRHDFDA,CRHDOUT,CRHDERR
.S CRHDFDA(CRHDFN,CRHDUPZ,.01)=CRHDAX
I $D(CRHDFDA) D
.S CRHDFDA(CRHDFN_".01","?+2,"_CRHDUPZ,.01)=CRHDPAR
.S:CRHDVAL'="" CRHDFDA(CRHDFN_".01","?+2,"_CRHDUPZ,1)=CRHDVAL
.D UPDATE^DIE("","CRHDFDA","CRHDOUT","CRHDERR")
.I '$D(CRHDERR) S CRHDMX=$G(CRHDOUT(2)),CRHDRTN(0)=1
.I $D(CRHDTXT) D
.S CRHDXX=0 F S CRHDXX=$O(^CRHD(CRHDFN,+CRHDUPZ,1,CRHDMX,1,CRHDXX)) Q:'CRHDXX D
..S DIE="^CRHD("_CRHDFN_","_CRHDUPZ_"1,"_CRHDMX_",1,",DA=CRHDXX,DR=".01///@"
..S DA(2)=+CRHDUPZ,DA(1)=CRHDMX
..D ^DIE
.S CRHDX=0
.F S CRHDX=$O(CRHDTXT(CRHDX)) Q:'CRHDX D
..S CRHDFDA(CRHDFN_.12,"?+"_(CRHDX+1)_","_CRHDMX_","_CRHDUPZ_"",.01)=$S($D(CRHDTXT(CRHDX,0)):CRHDTXT(CRHDX,0),1:CRHDTXT(CRHDX))
.D:$D(CRHDFDA) UPDATE^DIE("","CRHDFDA","CRHDOUT","CRHDERR")
.I '$D(CRHDERR) S CRHDRTN(0)=1
.E S CRHDRTN(0)="0^ERROR ENCOUNTERED STORING DATA"
K CRHDFDA,CRHDOUT,CRHDERR
Q
SAVELIST(CRHDRTN,CRHDLEV,CRHDTXT) ;process list of parameters
;list in the format:PARAMETER:VALUE
N CRHDI,CRHDPAR,CRHDVAL,CRHDFDA,CRHDUPY,CRHDUPZ,CRHDAX,CRHDL
K CRHDRTN
S CRHDRTN(0)=0_"^DATA NOT STORED"
S CRHDUPY=$$CHK(CRHDLEV)
S CRHDUPZ=$P(CRHDUPY,"^",2)
S CRHDAX=$P(CRHDUPY,"^",3)
S CRHDL=$L(CRHDLEV,"^")
I CRHDAX<1 S CRHDAX=+CRHDLEV_$G(CRHDVPTR($P(CRHDLEV,"^",CRHDL)))
I +CRHDAX S CRHDFDA(CRHDFN,CRHDUPZ,.01)=CRHDAX
I CRHDUPZ="+1," D
.D UPDATE^DIE("","CRHDFDA","CRHDOUT","CRHDERR")
.I '$D(CRHDERR) S CRHDUPZ=CRHDOUT(1)_",",CRHDRTN(0)=1
.K CRHDFDA,CRHDOUT,CRHDERR
S CRHDFDA(CRHDFN,CRHDUPZ,.01)=CRHDAX
S CRHDI=0
F S CRHDI=$O(CRHDTXT(CRHDI)) Q:'CRHDI D
.S CRHDPAR=$P(CRHDTXT(CRHDI),":",1)
.S CRHDVAL=$P(CRHDTXT(CRHDI),":",2,10)
.Q:CRHDPAR=""
.I CRHDVAL="" D DELPAR(+CRHDUPZ,CRHDPAR) Q
.I $D(CRHDFDA) D
..S CRHDFDA(CRHDFN_".01","?+"_CRHDI_","_CRHDUPZ,.01)=CRHDPAR
..S CRHDFDA(CRHDFN_".01","?+"_CRHDI_","_CRHDUPZ,1)=CRHDVAL
D UPDATE^DIE("","CRHDFDA","CRHDOUT","CRHDERR")
I '$D(CRHDERR) S CRHDRTN(0)=1
E S CRHDRTN(0)="0^ERROR SETTING DATA"
K CRHDFDA,CRHDOUT,CRHDERR
Q
CHK(CRHDL) ;
N CRHDFLG,Y,CRHDX ;FLG = 1 if record already exist
S CRHDFLG=0
I $P(CRHDL,"^",2)'="" D LOOKUP^XPAREDIT($P(CRHDL,"^",2),183)
I +Y>0 S CRHDX=+Y,CRHDFLG=1
I CRHDFLG S CRHDFLG=CRHDFLG_"^"_CRHDX_","_"^"_$P(Y,"^",2)
E S CRHDFLG=CRHDFLG_"^"_"+1,"_"^"_$P(Y,"^",2)
Q CRHDFLG
DELPAR(CRHDD1,CRHDDPAR) ;
N DA,DIE,DR
Q:'CRHDD1
S DA=$O(^CRHD(183,+CRHDD1,1,"B",CRHDPAR,0))
Q:'DA
S DIE="^CRHD(183,"_CRHDD1_",1,"
S DR=".01///@",DA(1)=CRHDD1
D ^DIE
Q
GETPLEV(CRHDDUZ,CRHDDIV,CRHDBYU) ;
N CRHDPAR,CRHDTEAM,CRHDSRV,Y,X,CRHDDIVI
S Y=-1
S CRHDTEAM=$$GET^XPAR("USR.`"_CRHDDUZ,"ORLP DEFAULT TEAM",1,"I")
S CRHDSRV=$$GET1^DIQ(200,CRHDDUZ_",",29,"E")
S CRHDPAR="USR.`"_CRHDDUZ
S:CRHDBYU CRHDPAR=""
I CRHDPAR'="" D LOOKUP^XPAREDIT(CRHDPAR,183)
I (Y<0)&($G(CRHDTEAM)>0) S CRHDPAR="OTL.`"_+CRHDTEAM D LOOKUP^XPAREDIT(CRHDPAR,183)
I (Y<0)&($G(CRHDSRV)'="") S CRHDPAR="SRV."_CRHDSRV D LOOKUP^XPAREDIT(CRHDPAR,183)
I '+$G(CRHDDIV) S CRHDDIV=+$$SITE^VASITE
I (Y<0) S CRHDPAR="DIV.`"_+CRHDDIV D LOOKUP^XPAREDIT(CRHDPAR,183)
I (Y<0) D
.S CRHDDIVI=$O(^DIC(4,"D",CRHDDIV,0))
.I CRHDDIVI S CRHDPAR="DIV.`"_CRHDDIVI D LOOKUP^XPAREDIT(CRHDPAR,183)
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HCRHD4 8117 printed Apr 09, 2024@21:40:13 Page 2
CRHD4 ; CAIRO/CLC - GET USERS PARAMETERS ;4/22/08 12:52
+1 ;;1.0;CRHD;****;Jan 28, 2008;Build 19
+2 ;=================================================================
GETALLP(CRHDRTN,CRHDUSR,CRHDDIV,CRHDPLEV) ;get all of the users parameters
+1 NEW X,X1,X2,CRHDCT,CRHDDOFG,CRHDMN,CRHDP,CRHDRSL,I,CRHDAX
+2 NEW CRHDL,CRHDVPTR,CRHDPN
+3 KILL CRHDRTN
+4 ;NEW PERSON
SET CRHDVPTR("USR")=";VA(200,"
+5 ;OE/RR TEAM
SET CRHDVPTR("OTL")=";OR(100.21,"
+6 ;SERVICE/SERVICE
SET CRHDVPTR("SRV")=";DIC(49,"
+7 ;INSTITUTION
SET CRHDVPTR("DIV")=";DIC(4,"
+8 ;TREATING SPECIALTY
SET CRHDVPTR("TS")=";DIC(45.7,"
+9 ;HOSPITAL LOCATION
SET CRHDVPTR("LOC")=";SC("
+10 ;SD TEAM
SET CRHDVPTR("SD")=";SCTM(404.51,"
+11 SET CRHDAX=+$GET(CRHDPLEV)
+12 SET CRHDL=$LENGTH($GET(CRHDPLEV),"^")
+13 IF CRHDAX
Begin DoDot:1
+14 SET CRHDAX=CRHDAX_$GET(CRHDVPTR($PIECE(CRHDPLEV,"^",CRHDL)))
+15 SET CRHDDOFG=$ORDER(^CRHD(183,"B",CRHDAX,0))
End DoDot:1
+16 IF $GET(CRHDPLEV)=""
SET CRHDDOFG=$$GETPLEV(CRHDUSR,CRHDDIV,0)
+17 IF CRHDDOFG>0
Begin DoDot:1
+18 IF CRHDDOFG["VA(200"
DO USRSET(.CRHDRSL,CRHDDOFG)
+19 IF $DATA(CRHDRSL)
SET CRHDDOFG=$$GETPLEV(CRHDUSR,CRHDDIV,1)
+20 SET CRHDMN=+CRHDDOFG
+21 SET (CRHDP,CRHDCT)=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 X2=0
FOR
SET X2=$ORDER(^CRHD(183,CRHDMN,1,CRHDP,1,X2))
if 'X2
QUIT
Begin DoDot:4
+26 IF $DATA(CRHDRSL($PIECE($GET(^CRHD(183,CRHDMN,1,CRHDP,0)),"^",1)))
QUIT
+27 ;I $D(CRHDRSL("STUDENT")) Q
+28 SET CRHDRTN(CRHDCT)=$PIECE($GET(^CRHD(183,CRHDMN,1,CRHDP,0)),"^",1)_"^"_$GET(^CRHD(183,CRHDMN,1,CRHDP,1,X2,0))
+29 SET CRHDCT=CRHDCT+1
End DoDot:4
End DoDot:3
+30 IF '$TEST
SET CRHDRTN(CRHDCT)=$GET(^CRHD(183,CRHDMN,1,CRHDP,0))
End DoDot:2
End DoDot:1
+31 IF $DATA(CRHDRSL)
Begin DoDot:1
+32 SET CRHDPN=""
+33 FOR
SET CRHDPN=$ORDER(CRHDRSL(CRHDPN))
if CRHDPN=""
QUIT
Begin DoDot:2
+34 SET CRHDX=0
+35 FOR
SET CRHDX=$ORDER(CRHDRSL(CRHDPN,CRHDX))
if 'CRHDX
QUIT
SET CRHDCT=CRHDCT+1
SET CRHDRTN(CRHDCT)=CRHDRSL(CRHDPN,CRHDX)
End DoDot:2
End DoDot:1
+36 QUIT
USRSET(CRHDLST,CRHDDA) ;
+1 NEW CRHDFG,CRHDX,CRHDP0,CRHDCT,CRHDX1
+2 SET (CRHDX,CRHDFG,CRHDCT)=0
+3 FOR
SET CRHDX=$ORDER(^CRHD(183,+CRHDDA,1,CRHDX))
if 'CRHDX
QUIT
Begin DoDot:1
+4 SET CRHDP0=$GET(^CRHD(183,+CRHDDA,1,CRHDX,0))
+5 IF $PIECE(CRHDP0,"^",2)=""
Begin DoDot:2
+6 SET CRHDX1=0
+7 FOR
SET CRHDX1=$ORDER(^CRHD(183,+CRHDDA,1,CRHDX,1,CRHDX1))
if 'CRHDX1
QUIT
SET CRHDCT=CRHDCT+1
SET CRHDLST(CRHDP0,CRHDCT)=$PIECE(CRHDP0,"^",1)_"^"_$GET(^CRHD(183,+CRHDDA,1,CRHDX,1,CRHDX1,0))
End DoDot:2
+8 IF '$TEST
SET CRHDCT=CRHDCT+1
SET CRHDLST($PIECE(CRHDP0,"^",1),CRHDCT)=CRHDP0
End DoDot:1
+9 QUIT
GETONEP(CRHDRTN,CRHDE,PNAME) ;Get one parameter from file 183
+1 NEW CRHDPAR,Y,X,CRHDCT,CRHDMN,CRHDP,CRHDE1,CRHDE2,CRHDE3,CRHDE4
+2 NEW CRHDX2,CRHDRSL,CRHDL,CRHDXCT,CRHDTRSL,CRHDEX,CRHDEE
+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($PIECE(CRHDE,"^",3),"-",1)
+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 CRHDPAR=CRHDE3_".`"_CRHDE1
+17 IF CRHDPAR'=""
DO LOOKUP^XPAREDIT(CRHDPAR,183)
+18 IF Y>-1
Begin DoDot:1
+19 SET CRHDMN=+Y
+20 SET CRHDP=$ORDER(^CRHD(183,CRHDMN,1,"B",PNAME,0))
+21 if 'CRHDP
QUIT
+22 IF $PIECE($GET(^CRHD(183,CRHDMN,1,+CRHDP,0)),"^",2)=""
Begin DoDot:2
+23 SET CRHDX2=0
FOR
SET CRHDX2=$ORDER(^CRHD(183,CRHDMN,1,+CRHDP,1,CRHDX2))
if 'CRHDX2
QUIT
Begin DoDot:3
+24 SET CRHDCT=CRHDCT+1
SET CRHDRTN(CRHDCT)=$GET(^CRHD(183,CRHDMN,1,+CRHDP,1,CRHDX2,0))
End DoDot:3
End DoDot:2
+25 IF '$TEST
SET CRHDRTN(1)=$PIECE($GET(^CRHD(183,CRHDMN,1,+CRHDP,0)),"^",2)
End DoDot:1
+26 QUIT
GETDNRT(CRHDRTN,CRHDUSR,CRHDDIV) ;get DNR Titles
+1 KILL CRHDRTN
+2 NEW CRHDDNR,CRHDX
+3 DO DNRPARM^CRHDDNR(.CRHDDNR,DUZ,CRHDDIV)
+4 IF $DATA(CRHDDNR)
Begin DoDot:1
+5 SET CRHDX=0
FOR
SET CRHDX=$ORDER(CRHDDNR(CRHDX))
if 'CRHDX
QUIT
SET CRHDRTN(CRHDX)=$PIECE(CRHDDNR(CRHDX),"^",2)
End DoDot:1
+6 QUIT
SAVEPARM(CRHDRTN,CRHDLEV,CRHDPAR,CRHDVAL,CRHDTXT) ;save parameters
+1 NEW Y,CRHDFN,CRHDFDA,CRHDERR,CRHDOUT,CRHDFILE,CRHDXX,CRHDUPY,CRHDUPZ
+2 NEW CRHDIENS,CRHDFLAG,CRHDANS,CRHDVPTR,CRHDL,DIE,DR,DA,CRHDAX
+3 ;NEW PERSON
SET CRHDVPTR("USR")=";VA(200,"
+4 ;OE/RR TEAM
SET CRHDVPTR("OTL")=";OR(100.21,"
+5 ;SERVICE/SERVICE
SET CRHDVPTR("SRV")=";DIC(49,"
+6 ;INSTITUTION
SET CRHDVPTR("DIV")=";DIC(4,"
+7 ;S CRHDVPTR("TS")=";DIC(45.7," ;TREATING SPECIALTY
+8 ;S CRHDVPTR("LOC")=";SC(" ;HOSPITAL LOCATION
+9 ;S CRHDVPTR("SD")=";SCTM(404.51," ;SD TEAM
+10 ;CRHD PARAMETER FILE NUMBER
SET CRHDFN=183
B KILL CRHDRTN
+1 SET CRHDRTN(0)="0^NO DATA STORED"
+2 IF $DATA(CRHDTXT)&((CRHDPAR="")&(CRHDVAL=""))
DO SAVELIST(.CRHDRTN,.CRHDLEV,.CRHDTXT)
QUIT
+3 IF CRHDPAR=""
SET CRHDRTN(0)="0^PARAMETER NAME MISSING"
QUIT
+4 SET CRHDUPY=$$CHK(CRHDLEV)
+5 SET CRHDUPZ=$PIECE(CRHDUPY,"^",2)
+6 SET CRHDAX=$PIECE(CRHDUPY,"^",3)
+7 SET CRHDL=$LENGTH(CRHDLEV,"^")
+8 IF CRHDAX<1
SET CRHDAX=+CRHDLEV_$GET(CRHDVPTR($PIECE(CRHDLEV,"^",CRHDL)))
+9 IF +CRHDAX
SET CRHDFDA(CRHDFN,CRHDUPZ,.01)=CRHDAX
+10 IF CRHDUPZ="+1,"
Begin DoDot:1
+11 DO UPDATE^DIE("","CRHDFDA","CRHDOUT","CRHDERR")
+12 IF '$DATA(CRHDERR)
SET CRHDUPZ=CRHDOUT(1)_","
SET CRHDRTN(0)=1
+13 KILL CRHDFDA,CRHDOUT,CRHDERR
+14 SET CRHDFDA(CRHDFN,CRHDUPZ,.01)=CRHDAX
End DoDot:1
+15 IF $DATA(CRHDFDA)
Begin DoDot:1
+16 SET CRHDFDA(CRHDFN_".01","?+2,"_CRHDUPZ,.01)=CRHDPAR
+17 if CRHDVAL'=""
SET CRHDFDA(CRHDFN_".01","?+2,"_CRHDUPZ,1)=CRHDVAL
+18 DO UPDATE^DIE("","CRHDFDA","CRHDOUT","CRHDERR")
+19 IF '$DATA(CRHDERR)
SET CRHDMX=$GET(CRHDOUT(2))
SET CRHDRTN(0)=1
+20 IF $DATA(CRHDTXT)
Begin DoDot:2
End DoDot:2
+21 SET CRHDXX=0
FOR
SET CRHDXX=$ORDER(^CRHD(CRHDFN,+CRHDUPZ,1,CRHDMX,1,CRHDXX))
if 'CRHDXX
QUIT
Begin DoDot:2
+22 SET DIE="^CRHD("_CRHDFN_","_CRHDUPZ_"1,"_CRHDMX_",1,"
SET DA=CRHDXX
SET DR=".01///@"
+23 SET DA(2)=+CRHDUPZ
SET DA(1)=CRHDMX
+24 DO ^DIE
End DoDot:2
+25 SET CRHDX=0
+26 FOR
SET CRHDX=$ORDER(CRHDTXT(CRHDX))
if 'CRHDX
QUIT
Begin DoDot:2
+27 SET CRHDFDA(CRHDFN_.12,"?+"_(CRHDX+1)_","_CRHDMX_","_CRHDUPZ_"",.01)=$SELECT($DATA(CRHDTXT(CRHDX,0)):CRHDTXT(CRHDX,0),1:CRHDTXT(CRHDX))
End DoDot:2
+28 if $DATA(CRHDFDA)
DO UPDATE^DIE("","CRHDFDA","CRHDOUT","CRHDERR")
+29 IF '$DATA(CRHDERR)
SET CRHDRTN(0)=1
+30 IF '$TEST
SET CRHDRTN(0)="0^ERROR ENCOUNTERED STORING DATA"
End DoDot:1
+31 KILL CRHDFDA,CRHDOUT,CRHDERR
+32 QUIT
SAVELIST(CRHDRTN,CRHDLEV,CRHDTXT) ;process list of parameters
+1 ;list in the format:PARAMETER:VALUE
+2 NEW CRHDI,CRHDPAR,CRHDVAL,CRHDFDA,CRHDUPY,CRHDUPZ,CRHDAX,CRHDL
+3 KILL CRHDRTN
+4 SET CRHDRTN(0)=0_"^DATA NOT STORED"
+5 SET CRHDUPY=$$CHK(CRHDLEV)
+6 SET CRHDUPZ=$PIECE(CRHDUPY,"^",2)
+7 SET CRHDAX=$PIECE(CRHDUPY,"^",3)
+8 SET CRHDL=$LENGTH(CRHDLEV,"^")
+9 IF CRHDAX<1
SET CRHDAX=+CRHDLEV_$GET(CRHDVPTR($PIECE(CRHDLEV,"^",CRHDL)))
+10 IF +CRHDAX
SET CRHDFDA(CRHDFN,CRHDUPZ,.01)=CRHDAX
+11 IF CRHDUPZ="+1,"
Begin DoDot:1
+12 DO UPDATE^DIE("","CRHDFDA","CRHDOUT","CRHDERR")
+13 IF '$DATA(CRHDERR)
SET CRHDUPZ=CRHDOUT(1)_","
SET CRHDRTN(0)=1
+14 KILL CRHDFDA,CRHDOUT,CRHDERR
End DoDot:1
+15 SET CRHDFDA(CRHDFN,CRHDUPZ,.01)=CRHDAX
+16 SET CRHDI=0
+17 FOR
SET CRHDI=$ORDER(CRHDTXT(CRHDI))
if 'CRHDI
QUIT
Begin DoDot:1
+18 SET CRHDPAR=$PIECE(CRHDTXT(CRHDI),":",1)
+19 SET CRHDVAL=$PIECE(CRHDTXT(CRHDI),":",2,10)
+20 if CRHDPAR=""
QUIT
+21 IF CRHDVAL=""
DO DELPAR(+CRHDUPZ,CRHDPAR)
QUIT
+22 IF $DATA(CRHDFDA)
Begin DoDot:2
+23 SET CRHDFDA(CRHDFN_".01","?+"_CRHDI_","_CRHDUPZ,.01)=CRHDPAR
+24 SET CRHDFDA(CRHDFN_".01","?+"_CRHDI_","_CRHDUPZ,1)=CRHDVAL
End DoDot:2
End DoDot:1
+25 DO UPDATE^DIE("","CRHDFDA","CRHDOUT","CRHDERR")
+26 IF '$DATA(CRHDERR)
SET CRHDRTN(0)=1
+27 IF '$TEST
SET CRHDRTN(0)="0^ERROR SETTING DATA"
+28 KILL CRHDFDA,CRHDOUT,CRHDERR
+29 QUIT
CHK(CRHDL) ;
+1 ;FLG = 1 if record already exist
NEW CRHDFLG,Y,CRHDX
+2 SET CRHDFLG=0
+3 IF $PIECE(CRHDL,"^",2)'=""
DO LOOKUP^XPAREDIT($PIECE(CRHDL,"^",2),183)
+4 IF +Y>0
SET CRHDX=+Y
SET CRHDFLG=1
+5 IF CRHDFLG
SET CRHDFLG=CRHDFLG_"^"_CRHDX_","_"^"_$PIECE(Y,"^",2)
+6 IF '$TEST
SET CRHDFLG=CRHDFLG_"^"_"+1,"_"^"_$PIECE(Y,"^",2)
+7 QUIT CRHDFLG
DELPAR(CRHDD1,CRHDDPAR) ;
+1 NEW DA,DIE,DR
+2 if 'CRHDD1
QUIT
+3 SET DA=$ORDER(^CRHD(183,+CRHDD1,1,"B",CRHDPAR,0))
+4 if 'DA
QUIT
+5 SET DIE="^CRHD(183,"_CRHDD1_",1,"
+6 SET DR=".01///@"
SET DA(1)=CRHDD1
+7 DO ^DIE
+8 QUIT
GETPLEV(CRHDDUZ,CRHDDIV,CRHDBYU) ;
+1 NEW CRHDPAR,CRHDTEAM,CRHDSRV,Y,X,CRHDDIVI
+2 SET Y=-1
+3 SET CRHDTEAM=$$GET^XPAR("USR.`"_CRHDDUZ,"ORLP DEFAULT TEAM",1,"I")
+4 SET CRHDSRV=$$GET1^DIQ(200,CRHDDUZ_",",29,"E")
+5 SET CRHDPAR="USR.`"_CRHDDUZ
+6 if CRHDBYU
SET CRHDPAR=""
+7 IF CRHDPAR'=""
DO LOOKUP^XPAREDIT(CRHDPAR,183)
+8 IF (Y<0)&($GET(CRHDTEAM)>0)
SET CRHDPAR="OTL.`"_+CRHDTEAM
DO LOOKUP^XPAREDIT(CRHDPAR,183)
+9 IF (Y<0)&($GET(CRHDSRV)'="")
SET CRHDPAR="SRV."_CRHDSRV
DO LOOKUP^XPAREDIT(CRHDPAR,183)
+10 IF '+$GET(CRHDDIV)
SET CRHDDIV=+$$SITE^VASITE
+11 IF (Y<0)
SET CRHDPAR="DIV.`"_+CRHDDIV
DO LOOKUP^XPAREDIT(CRHDPAR,183)
+12 IF (Y<0)
Begin DoDot:1
+13 SET CRHDDIVI=$ORDER(^DIC(4,"D",CRHDDIV,0))
+14 IF CRHDDIVI
SET CRHDPAR="DIV.`"_CRHDDIVI
DO LOOKUP^XPAREDIT(CRHDPAR,183)
End DoDot:1
+15 QUIT Y
