- 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 Feb 19, 2025@00:04:16 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