- 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 Jan 18, 2025@03:38:56 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