ECUMRPC1 ;ALB/JAM-Event Capture Management Broker Utilities ;Nov 12, 2020@15:34:23
;;2.0;EVENT CAPTURE;**25,30,33,72,94,95,105,100,107,110,112,126,130,131,134,139,152**;8 May 96;Build 19
;
DSSUNT(RESULTS,ECARY) ;
;
;This broker entry point returns DSS units from file 724
; RPC: EC GETDSSUNIT
;INPUTS ECARY -Contains the following subscripted elements
; P1 = optional field to return DSS Units
; STAT; 'A'ctive (default), 'I'nactive, 'B'oth
; P2 = optional field to filter based on the DSS Name
; P3 = optional field to return 1 DSS unit by IEN, if used
; no other filters evaluated
; P4 = optional field to filter based on the DSS Unit Number (DSS Dept)
;
; if data is passed into the other fields then all criteria
; must be met for data on a unit to be returned
;
;OUTPUTS RESULTS - Array of DSS units. Data pieces as follows:-
; PIECE - Description
; 1 IEN of DSS Unit
; 2 Name of DSS Unit
; 3 IEN of DSS Unit
; 4 Inactive flag
; 5 Send to PCE
; 6 Unit Number
; 7 Service
; 8 Medical Specialty
; 9 Cost Center
; 10 Associated Stop code (if not sending to PCE)
; 11 Category flag
; 12 Default date entry
; 13 Credit Stop Code (only available when SEND TO PCE is set to "no records"
; 14 CHAR4 code (only available when SEND TO PCE is set to "no records"
; 15 Allow duplicate records in spreadsheet upload
;
N UNT,STAT,CNT,CAT,NODE,ECS,STR,SRV,MED,CST,UNO,INACT,ASC,PCE,ACT,NODE
N DFD,DIEN,DNM,DUNIT,GET1,CSC,CHAR4,ADSS ;126,139
D SETENV^ECUMRPC
K ^TMP($J,"ECDSSUNT")
S DNM=$P($G(ECARY),U,2),DIEN=$P($G(ECARY),U,3),DUNIT=$P($G(ECARY),U,4)
S:DNM'="" DNM=$$UP^XLFSTR(DNM)
S:DUNIT'="" DUNIT=$$UP^XLFSTR(DUNIT)
S STAT=$P($G(ECARY),U),(CNT,UNT,GET1)=0 S:STAT="" STAT="A"
; if IEN passed in - use that, then quit, GET1 used as control to stop
I $G(DIEN) S UNT=DIEN-.001,GET1=1
F S UNT=$O(^ECD(UNT)) Q:'UNT!((UNT>DIEN&(GET1))) S NODE=$G(^ECD(UNT,0)) I NODE'="" D
. S ECS=$P(NODE,U,8),ACT=$P(NODE,U,6),ACT=$S(ACT:1,1:0)
. Q:('ECS)
. I '$G(DIEN),$S(STAT="A"&(ACT):1,STAT="I"&('ACT):1,1:0) Q
. ; execute new filters
. I DNM'="",$$UP^XLFSTR($P(NODE,U))'[DNM Q
. I DUNIT'="",$$UP^XLFSTR($P(NODE,U,5))'[DUNIT Q
. I DIEN'="",$$UP^XLFSTR(UNT)'[DIEN Q
. S CNT=CNT+1,CAT=$P(NODE,U,11),CAT=$S(CAT:"Y",1:"N"),UNO=$P(NODE,U,5)
. S SRV=$$GET1^DIQ(49,$P(NODE,U,2),.01,"I")
. S MED=$$GET1^DIQ(723,$P(NODE,U,3),.01,"I")
. S CST=$$GET1^DIQ(420.1,$P(NODE,U,4),.01,"I")
. S INACT=$P(NODE,U,6),INACT=$S(INACT:"I",1:"A"),ASC=$P(NODE,U,10),CSC=$P(NODE,U,13),CHAR4=$P(NODE,U,15) ;126
. S:ASC ASC=$$GET1^DIQ(40.7,ASC,.01,"I")
. S:CSC CSC=$$GET1^DIQ(40.7,CSC,.01) ;126
. S:CHAR4 CHAR4=$$GET1^DIQ(728.441,CHAR4,.01) ;126
. S DFD=$S($P(NODE,U,12)="N":"N",1:"X"),PCE=$P(NODE,U,14)
. S PCE=$S(PCE'="":PCE,1:"N") ;139
. S ADSS=$S($P(NODE,U,16)'="":$P(NODE,U,16),1:"N") ;139 Does DSS Unit allow duplicate record upload
. S STR=UNT_U_$P(NODE,U)_U_UNT_U_INACT_U_PCE_U_UNO_U_SRV_U_MED_U_CST
. S STR=STR_U_ASC_U_CAT_U_DFD_U_CSC_U_CHAR4_U_ADSS,^TMP($J,"ECDSSUNT",CNT)=STR ;126,139
S RESULTS=$NA(^TMP($J,"ECDSSUNT"))
Q
CAT(RESULTS,ECARY) ;
;
;This broker entry point returns a list of categories from file 726
; RPC: EC GETCAT
;INPUTS ECARY - Contains the following subscripted elements
; STAT - Active or inactive category (optional)
; A-ctive (default), I-nactive, B-oth
;
;OUTPUTS RESULTS - Array of category. Data pieces as follows:-
; PIECE - Description
; 1 IEN of Category
; 2 Name of Category
; 3 Creation Date
; 4 Inactive Date
;
N STAT,CNT,CAT,NODE,ECDT,INDT,CRDT
D SETENV^ECUMRPC
K ^TMP($J,"ECCAT")
S STAT=$P($G(ECARY),U),(CNT,CAT)=0 S:STAT="" STAT="A"
F S CAT=$O(^EC(726,CAT)) Q:'CAT S NODE=$G(^EC(726,CAT,0)) I NODE'="" D
. S ECDT=$P(NODE,U,3)
. I STAT="A",ECDT'="",ECDT'>DT Q
. I STAT="I",ECDT="" Q
. S CRDT=$$FMTE^XLFDT($P(NODE,U,2),"2F")
. S INDT=$$FMTE^XLFDT($P(NODE,U,3),"2F")
. ;S CNT=CNT+1,^TMP($J,"ECCAT",CNT)=CAT_U_$P(NODE,U)_U_CRDT_U_INDT
. S CNT=CNT+1,^TMP($J,"ECCAT",CNT)=CAT_U_$P(NODE,U)_U_$P(CRDT,"@",1)_U_$P(INDT,"@",1)
S RESULTS=$NA(^TMP($J,"ECCAT"))
Q
;
CATCHK(RESULTS,ECARY) ;
;
;Broker call checks whether category is used in an Event Code Screen.
; RPC: EC DSSCATCHECK
;INPUTS ECARY - Contains the following subscripted elements
; ECDA - DSS Unit ien (file #724)
;
;OUTPUTS RESULTS - Category used in Event Code Screen, 1-Yes or 0-No
;
N ECDA,ECFLG,ECX
D SETENV^ECUMRPC
S ECDA=$P(ECARY,U) I ECDA="" Q
S (ECFLG,ECX)=0
F S ECX=$O(^ECJ("AP",ECX)) Q:'ECX!(ECFLG) D
. I $D(^ECJ("AP",ECX,ECDA)) S ECFLG=1
S RESULTS=ECFLG
Q
PXCHK(RESULTS,ECARY) ;
;
;Checks whether procedure description or national number exist
;INPUTS ECARY - Contains the following subscripted elements
; ECP - Procedure description
; ECN - EC National Number
;
;OUTPUTS RESULTS - Px used^National # used, 1-Yes or 0-No ex. 1^0
;
N ECX,ECP,ECN
Q:$G(ECARY)
D SETENV^ECUMRPC
S ECP=$P(ECARY,U),ECN=$P(ECARY,U,2),RESULTS="0^0"
I ECP'="",$D(^EC(725,"B",ECP)) S $P(RESULTS,U)=1
I ECN'="" F ECX="E","D","DL" D I $P(RESULTS,U,2) Q
. I $D(^EC(725,ECX,ECN)) S $P(RESULTS,U,2)=1
Q
SRCLST(RESULTS,ECARY) ;
;
;This broker entry returns an array of codes from a file based on a
;search string.
; RPC: EC GETLIST
;
;INPUTS ECARY - Contains the following subscripted elements
; ECFIL - File to search
; ECSTR - Search string
; ECDIR - Search order
; ECNUM - (Optional) # records to return [default=44]
; ECADT - (Optional) date to determine clinic inactivity
; ECLOC - (Optional) location to filter associated clinics
; ECTYPE - (Optional) primary or secondary stop codes desired
; ECOOS - (Optional) Set to "OOS" to only see "OOS" related stop codes
;OUTPUTS RESULTS - Array of values based on the search criteria.
;
N ECNT,DIC,ECSTR,ECFIL,ECORD,ECER,ECDI,ECNUM,ECDIR,ECADT,ECLOC,ECTYPE,ECOOS ;112,126,139
D SETENV^ECUMRPC
S ECNT=0,ECFIL=$P(ECARY,U),ECSTR=$P(ECARY,U,2),ECDIR=$P(ECARY,U,3)
S ECORD=$S(ECDIR=-1:"B",1:"I")
K ^TMP($J,"ECFIND"),^TMP("ECSRCH",$J)
I ECFIL="" Q
S ECNUM=$S(+$P(ECARY,U,4)>0:$P(ECARY,U,4),1:44)
S ECADT=$S(+$P(ECARY,U,5):$P(ECARY,U,5),1:DT) ;112
S ECLOC=$P(ECARY,U,6) ;126 IEN of location if filtering. Null if no filtering
S ECTYPE=$P(ECARY,U,7) ;126 Null if primary, not null for secondary
S ECOOS=$P(ECARY,U,8) ;139 Set to "OOS" if list is restricted to "OOS" type stop codes
I ECFIL=420.1 D CSTCTR ;Cost Center search
I ECFIL=49 D SERVC ;Service search
I ECFIL=723 D MEDSPC ;Medical specialty
I ECFIL=40.7 D STPCDE G EXIT ;Associated stop code
I ECFIL=724 D DUNT G EXIT ;DSS Unit
I ECFIL=726 D ECAT ;Category
I ECFIL=4 D LOC ;Location
I ECFIL=44 D ASCLN G EXIT ;Associated clinic
I ECFIL=757.01 D LEX^ECUMRPC2 G EXIT ;Lex ICD code
I ECFIL=200 D PROV^ECUMRPC2(ECNUM) ;Providers
I ECFIL=728.441 D CHAR4 ;126 National Clinic code (CHAR4)
I ECFIL=722 D LIST^ECPRVDR ;134 EC Providers
I $D(ECER) S ^TMP($J,"ECFIND",1)="0^Error occurred during search" G EXIT
D SORT
EXIT K ^TMP("ECSRCH",$J)
S RESULTS=$NA(^TMP($J,"ECFIND"))
Q
ASCLN ;Search for active associated clinics (file #44)
N CLN,CNT,NOD,ECDT,INACT,REACT,ERR,ECNOD ;126
N ECRES,ECAC ;152
S CNT=0,ECDT=ECADT ;112
I (ECDIR'=1)&(ECDIR'=-1) S ECDIR=1
;the next 2 lines of code compensate for the M collating sequence & how the
;clinic code is passed in from a CPRS RPC, in a unique situation. If the
;code is numeric, ending in 0 and there is a similar code ending with a
;letter, the correct clinic is not returned. EX: 2 clinics, 3010 and "3010A"
;exist, the code is written to return 3010, yet 3010A is incorrectly returned.
;This code puts the 0 back on and subtracts 1 to the clinic code
I $E(ECSTR,$L(ECSTR)-1)="/",$E(ECSTR,1,($L(ECSTR)-2))?.N D
.S ECSTR=$E(ECSTR,1,($L(ECSTR)-2))_0,ECSTR=ECSTR-1
F Q:CNT'<ECNUM S ECSTR=$O(^SC("B",ECSTR),ECDIR) Q:ECSTR="" S CLN="" D ;134 Stop if counter is greater than or equal to ECNUM - allows for duplicate clinic names
.F S CLN=$O(^SC("B",ECSTR,CLN),ECDIR) Q:CLN="" S NOD=$G(^SC(CLN,0)) D
..Q:NOD="" Q:$P(NOD,U,3)'="C" ;Q:+$G(^SC(CLN,"OOS"))
..I $G(ECLOC) I ECLOC'=$$GET1^DIQ(44,CLN,"3.5:.07","I") Q ;126,130 Clinic must be assoicated with the selected location, if one was selected
..S ERR=0 I $D(^SC(CLN,"I")) D I ERR Q
...S INACT=$P(^SC(CLN,"I"),U),REACT=$P(^SC(CLN,"I"),U,2)
...I INACT D I ERR Q
....I REACT="" S:ECDT'<INACT ERR=1 Q
....I ECDT'<INACT,ECDT<REACT S ERR=1 Q
...;I REACT,ECDT<REACT S ERR=1 removed in EC*110 - BGP
..S ECNOD=$G(^ECX(728.44,CLN,0)) ;126 Get clinic and stop code zero node for selected clinic
..;S CNT=CNT+1,^TMP($J,"ECFIND",CNT)=CLN_U_$P(NOD,U)_U_$P(ECNOD,U,2)_U_$P(ECNOD,U,3)_U_$P($G(^ECX(728.441,+$P(ECNOD,U,8),0)),U) ;126 Add stop code, credit stop, and char4 code
..I $P(ECNOD,U,2)'="" D ;152 Only valid clinics are added to the list
...S ECRES=$$CLNCK^SDUTL2(CLN,0) I 'ECRES Q ;
...S CNT=CNT+1,^TMP($J,"ECFIND",CNT)=CLN_U_$P(NOD,U)_U_$P(ECNOD,U,2)_U_$P(ECNOD,U,3)_U_$P($G(^ECX(728.441,+$P(ECNOD,U,8),0)),U) ;126 Add stop code, credit stop, and char4 code
Q
CSTCTR ;Search for cost centers (File #420.1)
N ECNULL,INDX,STR,NSTR,I
S $P(ECNULL," ",7)=" ",INDX="B"
I $E(ECSTR)?.N,$L(ECSTR)<7 S ECSTR=ECSTR_$E(ECNULL,1,7-$L(ECSTR))
I $L($P(ECSTR," "))=6,$P(ECSTR," ",2)?.A D ;truncate for x-ref
. S ECSTR=$P(ECSTR," ")_" "_$E($P(ECSTR," ",2,999),1,22)
I $E(ECSTR)?.A S INDX="C",(STR,NSTR)="" D S ECSTR=NSTR
.F I=1:1 S STR=$P(ECSTR," ",I) Q:STR="" D
..S STR=$E(STR)_$TR($E(STR,2,9999),"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
..S NSTR=NSTR_STR
D LISTDIC(ECFIL,"",.01,ECORD,ECNUM,ECSTR,"",INDX,"I '$P(^(0),U,2)","","^TMP(""ECSRCH"",$J)","ECER")
Q
SERVC ;Search for services (File #49)
D LISTDIC(ECFIL,"",.01,ECORD,ECNUM,ECSTR,"","","","","^TMP(""ECSRCH"",$J)","ECER")
Q
MEDSPC ;Search for medical specialty (File #723)
D LISTDIC(ECFIL,"",.01,ECORD,ECNUM,ECSTR,"","","","","^TMP(""ECSRCH"",$J)","ECER")
Q
STPCDE ;Search for associated stop code (File #40.7)
N ECNT,INDX,ECNUL,STR,IEN,SCRN ;139
S $P(ECNUL," ",30)=" ",INDX="B",ECNT=0,ECSTR=$P(ECSTR,"~")
I +ECSTR,ECSTR["/" S ECSTR=$TR(ECSTR,"/",0) S:ECSTR>0 ECSTR=ECSTR-1 ;131 If number sent, remove / and replace with 0
I +ECSTR,+ECSTR?.N S INDX="C",IEN=0 D Q
.S ECSTR=$O(^DIC(40.7,INDX,+ECSTR)) I ECSTR="" Q
.F S IEN=$O(^DIC(40.7,INDX,ECSTR,IEN)) Q:'IEN D I ECNT>(ECNUM-1) Q
..;07/27/09 llh added checks on piece 2 and 6
..S STR=$G(^DIC(40.7,IEN,0)) I ($P(STR,U,3)'=""&($P(STR,U,3)'>DT))!($P(STR,U,6)=$S($G(ECTYPE)="":"S",1:"P"))!($P(STR,U,6)="")!($L($P(STR,U,2))'=3) Q ;126 allow for searches for primary or secondary
..I $G(ECOOS)="OOS" I '$$EX^SDCOU2(IEN,$$NOW^XLFDT) Q ;139 If setting up OOS DSS unit, only show OOS related stop codes
..S STR=$E($P(STR,U),1,30)_" ["_$J($P(STR,U,2),3,0)_"]"_U_$P(STR,U,2)_U_IEN
..S ECNT=ECNT+1,^TMP($J,"ECFIND",ECNT)=STR
;added validation checks here as well
S SCRN="I $P(^(0),U,3)=""""!($P(^(0),U,3)'<DT)&($L($P(^(0),U,2))=3)&(($P(^(0),U,6)=$S($G(ECTYPE)="""":""P"",1:""S""))!($P(^(0),U,6)=""E""))"_$S(ECOOS="OOS":" I $$EX^SDCOU2(Y,$$NOW^XLFDT)",1:"") ;139
D LISTDIC(ECFIL,"",".01;1",ECORD,ECNUM,ECSTR,"",INDX,SCRN,"","^TMP(""ECSRCH"",$J)","ECER") ;126,139
S ECNT=0
F S ECNT=$O(^TMP("ECSRCH",$J,"DILIST","ID",ECNT)) Q:'ECNT D
.S STR=$G(^TMP("ECSRCH",$J,"DILIST","ID",ECNT,.01))_U_$G(^(1))
.S STR=$E($P(STR,U),1,30)_" ["_$J($P(STR,U,2),3,0)_"]"_U_$P(STR,U,2)
.S ^TMP($J,"ECFIND",ECNT)=STR_U_^TMP("ECSRCH",$J,"DILIST",2,ECNT)
Q
DUNT ;Search for DSS unit (File #724)
N ECNT,SNDPCE
D LISTDIC(ECFIL,"",".01;10;13",ECORD,ECNUM,ECSTR,"","","I '$P(^(0),""^"",6),$P(^(0),U,8)","","^TMP(""ECSRCH"",$J)","ECER")
S ECNT=0
F S ECNT=$O(^TMP("ECSRCH",$J,"DILIST","ID",ECNT)) Q:'ECNT D
.S SNDPCE=$G(^TMP("ECSRCH",$J,"DILIST","ID",ECNT,13))
.S SNDPCE=$S(SNDPCE="A":1,1:0) ;139 Send all records enables clinic selection, else no clinic
.S ^TMP($J,"ECFIND",ECNT)=$G(^TMP("ECSRCH",$J,"DILIST","ID",ECNT,.01))_U_^TMP("ECSRCH",$J,"DILIST",2,ECNT)_U_$G(^TMP("ECSRCH",$J,"DILIST","ID",ECNT,10))_U_SNDPCE
Q
ECAT ;Search for Category (File #726)
D LISTDIC(ECFIL,"",.01,ECORD,ECNUM,ECSTR,"","","I $P(^(0),""^"",3)=""""!($P(^(0),U,3)>DT)","","^TMP(""ECSRCH"",$J)","ECER")
Q
LOC ;Search for Location (File #4)
D LISTDIC(ECFIL,"",.01,ECORD,ECNUM,ECSTR,"","","I $G(^(""EC""))","","^TMP(""ECSRCH"",$J)","ECER")
Q
LISTDIC(ECFL,ECIEN,ECFLD,ECFLG,ECNUM,ECFRM,ECPRT,ECINDX,ECSCN,ECIND,ECTG,ECER) ;
;Produces a list of records in a file base on search string
N DIC
D LIST^DIC(ECFL,ECIEN,ECFLD,ECFLG,ECNUM,ECFRM,ECPRT,ECINDX,ECSCN,ECIND,ECTG,ECER)
K ECFL,ECIEN,ECFLD,ECFLG,ECNUM,ECFRM,ECPRT,ECINDX,ECSCN,ECID
Q
SORT ;Extracts data to be returned to broker
N ECNT,STR
S ECNT=0
F S ECNT=$O(^TMP("ECSRCH",$J,"DILIST","ID",ECNT)) Q:'ECNT D
.S ^TMP($J,"ECFIND",ECNT)=$G(^TMP("ECSRCH",$J,"DILIST","ID",ECNT,.01))_U_^TMP("ECSRCH",$J,"DILIST",2,ECNT)
Q
;
CHAR4 ;126, returns list of CHAR4 codes from the NATIONAL CLINIC file (#728.441)
D LISTDIC(ECFIL,"",.01,ECORD,ECNUM,ECSTR,"","","I $P($G(^(2)),""^"")=""""!($P($G(^(2)),""^"")>DT)","","^TMP(""ECSRCH"",$J)","ECER")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECUMRPC1 14172 printed Nov 22, 2024@17:09:16 Page 2
ECUMRPC1 ;ALB/JAM-Event Capture Management Broker Utilities ;Nov 12, 2020@15:34:23
+1 ;;2.0;EVENT CAPTURE;**25,30,33,72,94,95,105,100,107,110,112,126,130,131,134,139,152**;8 May 96;Build 19
+2 ;
DSSUNT(RESULTS,ECARY) ;
+1 ;
+2 ;This broker entry point returns DSS units from file 724
+3 ; RPC: EC GETDSSUNIT
+4 ;INPUTS ECARY -Contains the following subscripted elements
+5 ; P1 = optional field to return DSS Units
+6 ; STAT; 'A'ctive (default), 'I'nactive, 'B'oth
+7 ; P2 = optional field to filter based on the DSS Name
+8 ; P3 = optional field to return 1 DSS unit by IEN, if used
+9 ; no other filters evaluated
+10 ; P4 = optional field to filter based on the DSS Unit Number (DSS Dept)
+11 ;
+12 ; if data is passed into the other fields then all criteria
+13 ; must be met for data on a unit to be returned
+14 ;
+15 ;OUTPUTS RESULTS - Array of DSS units. Data pieces as follows:-
+16 ; PIECE - Description
+17 ; 1 IEN of DSS Unit
+18 ; 2 Name of DSS Unit
+19 ; 3 IEN of DSS Unit
+20 ; 4 Inactive flag
+21 ; 5 Send to PCE
+22 ; 6 Unit Number
+23 ; 7 Service
+24 ; 8 Medical Specialty
+25 ; 9 Cost Center
+26 ; 10 Associated Stop code (if not sending to PCE)
+27 ; 11 Category flag
+28 ; 12 Default date entry
+29 ; 13 Credit Stop Code (only available when SEND TO PCE is set to "no records"
+30 ; 14 CHAR4 code (only available when SEND TO PCE is set to "no records"
+31 ; 15 Allow duplicate records in spreadsheet upload
+32 ;
+33 NEW UNT,STAT,CNT,CAT,NODE,ECS,STR,SRV,MED,CST,UNO,INACT,ASC,PCE,ACT,NODE
+34 ;126,139
NEW DFD,DIEN,DNM,DUNIT,GET1,CSC,CHAR4,ADSS
+35 DO SETENV^ECUMRPC
+36 KILL ^TMP($JOB,"ECDSSUNT")
+37 SET DNM=$PIECE($GET(ECARY),U,2)
SET DIEN=$PIECE($GET(ECARY),U,3)
SET DUNIT=$PIECE($GET(ECARY),U,4)
+38 if DNM'=""
SET DNM=$$UP^XLFSTR(DNM)
+39 if DUNIT'=""
SET DUNIT=$$UP^XLFSTR(DUNIT)
+40 SET STAT=$PIECE($GET(ECARY),U)
SET (CNT,UNT,GET1)=0
if STAT=""
SET STAT="A"
+41 ; if IEN passed in - use that, then quit, GET1 used as control to stop
+42 IF $GET(DIEN)
SET UNT=DIEN-.001
SET GET1=1
+43 FOR
SET UNT=$ORDER(^ECD(UNT))
if 'UNT!((UNT>DIEN&(GET1)))
QUIT
SET NODE=$GET(^ECD(UNT,0))
IF NODE'=""
Begin DoDot:1
+44 SET ECS=$PIECE(NODE,U,8)
SET ACT=$PIECE(NODE,U,6)
SET ACT=$SELECT(ACT:1,1:0)
+45 if ('ECS)
QUIT
+46 IF '$GET(DIEN)
IF $SELECT(STAT="A"&(ACT):1,STAT="I"&('ACT):1,1:0)
QUIT
+47 ; execute new filters
+48 IF DNM'=""
IF $$UP^XLFSTR($PIECE(NODE,U))'[DNM
QUIT
+49 IF DUNIT'=""
IF $$UP^XLFSTR($PIECE(NODE,U,5))'[DUNIT
QUIT
+50 IF DIEN'=""
IF $$UP^XLFSTR(UNT)'[DIEN
QUIT
+51 SET CNT=CNT+1
SET CAT=$PIECE(NODE,U,11)
SET CAT=$SELECT(CAT:"Y",1:"N")
SET UNO=$PIECE(NODE,U,5)
+52 SET SRV=$$GET1^DIQ(49,$PIECE(NODE,U,2),.01,"I")
+53 SET MED=$$GET1^DIQ(723,$PIECE(NODE,U,3),.01,"I")
+54 SET CST=$$GET1^DIQ(420.1,$PIECE(NODE,U,4),.01,"I")
+55 ;126
SET INACT=$PIECE(NODE,U,6)
SET INACT=$SELECT(INACT:"I",1:"A")
SET ASC=$PIECE(NODE,U,10)
SET CSC=$PIECE(NODE,U,13)
SET CHAR4=$PIECE(NODE,U,15)
+56 if ASC
SET ASC=$$GET1^DIQ(40.7,ASC,.01,"I")
+57 ;126
if CSC
SET CSC=$$GET1^DIQ(40.7,CSC,.01)
+58 ;126
if CHAR4
SET CHAR4=$$GET1^DIQ(728.441,CHAR4,.01)
+59 SET DFD=$SELECT($PIECE(NODE,U,12)="N":"N",1:"X")
SET PCE=$PIECE(NODE,U,14)
+60 ;139
SET PCE=$SELECT(PCE'="":PCE,1:"N")
+61 ;139 Does DSS Unit allow duplicate record upload
SET ADSS=$SELECT($PIECE(NODE,U,16)'="":$PIECE(NODE,U,16),1:"N")
+62 SET STR=UNT_U_$PIECE(NODE,U)_U_UNT_U_INACT_U_PCE_U_UNO_U_SRV_U_MED_U_CST
+63 ;126,139
SET STR=STR_U_ASC_U_CAT_U_DFD_U_CSC_U_CHAR4_U_ADSS
SET ^TMP($JOB,"ECDSSUNT",CNT)=STR
End DoDot:1
+64 SET RESULTS=$NAME(^TMP($JOB,"ECDSSUNT"))
+65 QUIT
CAT(RESULTS,ECARY) ;
+1 ;
+2 ;This broker entry point returns a list of categories from file 726
+3 ; RPC: EC GETCAT
+4 ;INPUTS ECARY - Contains the following subscripted elements
+5 ; STAT - Active or inactive category (optional)
+6 ; A-ctive (default), I-nactive, B-oth
+7 ;
+8 ;OUTPUTS RESULTS - Array of category. Data pieces as follows:-
+9 ; PIECE - Description
+10 ; 1 IEN of Category
+11 ; 2 Name of Category
+12 ; 3 Creation Date
+13 ; 4 Inactive Date
+14 ;
+15 NEW STAT,CNT,CAT,NODE,ECDT,INDT,CRDT
+16 DO SETENV^ECUMRPC
+17 KILL ^TMP($JOB,"ECCAT")
+18 SET STAT=$PIECE($GET(ECARY),U)
SET (CNT,CAT)=0
if STAT=""
SET STAT="A"
+19 FOR
SET CAT=$ORDER(^EC(726,CAT))
if 'CAT
QUIT
SET NODE=$GET(^EC(726,CAT,0))
IF NODE'=""
Begin DoDot:1
+20 SET ECDT=$PIECE(NODE,U,3)
+21 IF STAT="A"
IF ECDT'=""
IF ECDT'>DT
QUIT
+22 IF STAT="I"
IF ECDT=""
QUIT
+23 SET CRDT=$$FMTE^XLFDT($PIECE(NODE,U,2),"2F")
+24 SET INDT=$$FMTE^XLFDT($PIECE(NODE,U,3),"2F")
+25 ;S CNT=CNT+1,^TMP($J,"ECCAT",CNT)=CAT_U_$P(NODE,U)_U_CRDT_U_INDT
+26 SET CNT=CNT+1
SET ^TMP($JOB,"ECCAT",CNT)=CAT_U_$PIECE(NODE,U)_U_$PIECE(CRDT,"@",1)_U_$PIECE(INDT,"@",1)
End DoDot:1
+27 SET RESULTS=$NAME(^TMP($JOB,"ECCAT"))
+28 QUIT
+29 ;
CATCHK(RESULTS,ECARY) ;
+1 ;
+2 ;Broker call checks whether category is used in an Event Code Screen.
+3 ; RPC: EC DSSCATCHECK
+4 ;INPUTS ECARY - Contains the following subscripted elements
+5 ; ECDA - DSS Unit ien (file #724)
+6 ;
+7 ;OUTPUTS RESULTS - Category used in Event Code Screen, 1-Yes or 0-No
+8 ;
+9 NEW ECDA,ECFLG,ECX
+10 DO SETENV^ECUMRPC
+11 SET ECDA=$PIECE(ECARY,U)
IF ECDA=""
QUIT
+12 SET (ECFLG,ECX)=0
+13 FOR
SET ECX=$ORDER(^ECJ("AP",ECX))
if 'ECX!(ECFLG)
QUIT
Begin DoDot:1
+14 IF $DATA(^ECJ("AP",ECX,ECDA))
SET ECFLG=1
End DoDot:1
+15 SET RESULTS=ECFLG
+16 QUIT
PXCHK(RESULTS,ECARY) ;
+1 ;
+2 ;Checks whether procedure description or national number exist
+3 ;INPUTS ECARY - Contains the following subscripted elements
+4 ; ECP - Procedure description
+5 ; ECN - EC National Number
+6 ;
+7 ;OUTPUTS RESULTS - Px used^National # used, 1-Yes or 0-No ex. 1^0
+8 ;
+9 NEW ECX,ECP,ECN
+10 if $GET(ECARY)
QUIT
+11 DO SETENV^ECUMRPC
+12 SET ECP=$PIECE(ECARY,U)
SET ECN=$PIECE(ECARY,U,2)
SET RESULTS="0^0"
+13 IF ECP'=""
IF $DATA(^EC(725,"B",ECP))
SET $PIECE(RESULTS,U)=1
+14 IF ECN'=""
FOR ECX="E","D","DL"
Begin DoDot:1
+15 IF $DATA(^EC(725,ECX,ECN))
SET $PIECE(RESULTS,U,2)=1
End DoDot:1
IF $PIECE(RESULTS,U,2)
QUIT
+16 QUIT
SRCLST(RESULTS,ECARY) ;
+1 ;
+2 ;This broker entry returns an array of codes from a file based on a
+3 ;search string.
+4 ; RPC: EC GETLIST
+5 ;
+6 ;INPUTS ECARY - Contains the following subscripted elements
+7 ; ECFIL - File to search
+8 ; ECSTR - Search string
+9 ; ECDIR - Search order
+10 ; ECNUM - (Optional) # records to return [default=44]
+11 ; ECADT - (Optional) date to determine clinic inactivity
+12 ; ECLOC - (Optional) location to filter associated clinics
+13 ; ECTYPE - (Optional) primary or secondary stop codes desired
+14 ; ECOOS - (Optional) Set to "OOS" to only see "OOS" related stop codes
+15 ;OUTPUTS RESULTS - Array of values based on the search criteria.
+16 ;
+17 ;112,126,139
NEW ECNT,DIC,ECSTR,ECFIL,ECORD,ECER,ECDI,ECNUM,ECDIR,ECADT,ECLOC,ECTYPE,ECOOS
+18 DO SETENV^ECUMRPC
+19 SET ECNT=0
SET ECFIL=$PIECE(ECARY,U)
SET ECSTR=$PIECE(ECARY,U,2)
SET ECDIR=$PIECE(ECARY,U,3)
+20 SET ECORD=$SELECT(ECDIR=-1:"B",1:"I")
+21 KILL ^TMP($JOB,"ECFIND"),^TMP("ECSRCH",$JOB)
+22 IF ECFIL=""
QUIT
+23 SET ECNUM=$SELECT(+$PIECE(ECARY,U,4)>0:$PIECE(ECARY,U,4),1:44)
+24 ;112
SET ECADT=$SELECT(+$PIECE(ECARY,U,5):$PIECE(ECARY,U,5),1:DT)
+25 ;126 IEN of location if filtering. Null if no filtering
SET ECLOC=$PIECE(ECARY,U,6)
+26 ;126 Null if primary, not null for secondary
SET ECTYPE=$PIECE(ECARY,U,7)
+27 ;139 Set to "OOS" if list is restricted to "OOS" type stop codes
SET ECOOS=$PIECE(ECARY,U,8)
+28 ;Cost Center search
IF ECFIL=420.1
DO CSTCTR
+29 ;Service search
IF ECFIL=49
DO SERVC
+30 ;Medical specialty
IF ECFIL=723
DO MEDSPC
+31 ;Associated stop code
IF ECFIL=40.7
DO STPCDE
GOTO EXIT
+32 ;DSS Unit
IF ECFIL=724
DO DUNT
GOTO EXIT
+33 ;Category
IF ECFIL=726
DO ECAT
+34 ;Location
IF ECFIL=4
DO LOC
+35 ;Associated clinic
IF ECFIL=44
DO ASCLN
GOTO EXIT
+36 ;Lex ICD code
IF ECFIL=757.01
DO LEX^ECUMRPC2
GOTO EXIT
+37 ;Providers
IF ECFIL=200
DO PROV^ECUMRPC2(ECNUM)
+38 ;126 National Clinic code (CHAR4)
IF ECFIL=728.441
DO CHAR4
+39 ;134 EC Providers
IF ECFIL=722
DO LIST^ECPRVDR
+40 IF $DATA(ECER)
SET ^TMP($JOB,"ECFIND",1)="0^Error occurred during search"
GOTO EXIT
+41 DO SORT
EXIT KILL ^TMP("ECSRCH",$JOB)
+1 SET RESULTS=$NAME(^TMP($JOB,"ECFIND"))
+2 QUIT
ASCLN ;Search for active associated clinics (file #44)
+1 ;126
NEW CLN,CNT,NOD,ECDT,INACT,REACT,ERR,ECNOD
+2 ;152
NEW ECRES,ECAC
+3 ;112
SET CNT=0
SET ECDT=ECADT
+4 IF (ECDIR'=1)&(ECDIR'=-1)
SET ECDIR=1
+5 ;the next 2 lines of code compensate for the M collating sequence & how the
+6 ;clinic code is passed in from a CPRS RPC, in a unique situation. If the
+7 ;code is numeric, ending in 0 and there is a similar code ending with a
+8 ;letter, the correct clinic is not returned. EX: 2 clinics, 3010 and "3010A"
+9 ;exist, the code is written to return 3010, yet 3010A is incorrectly returned.
+10 ;This code puts the 0 back on and subtracts 1 to the clinic code
+11 IF $EXTRACT(ECSTR,$LENGTH(ECSTR)-1)="/"
IF $EXTRACT(ECSTR,1,($LENGTH(ECSTR)-2))?.N
Begin DoDot:1
+12 SET ECSTR=$EXTRACT(ECSTR,1,($LENGTH(ECSTR)-2))_0
SET ECSTR=ECSTR-1
End DoDot:1
+13 ;134 Stop if counter is greater than or equal to ECNUM - allows for duplicate clinic names
FOR
if CNT'<ECNUM
QUIT
SET ECSTR=$ORDER(^SC("B",ECSTR),ECDIR)
if ECSTR=""
QUIT
SET CLN=""
Begin DoDot:1
+14 FOR
SET CLN=$ORDER(^SC("B",ECSTR,CLN),ECDIR)
if CLN=""
QUIT
SET NOD=$GET(^SC(CLN,0))
Begin DoDot:2
+15 ;Q:+$G(^SC(CLN,"OOS"))
if NOD=""
QUIT
if $PIECE(NOD,U,3)'="C"
QUIT
+16 ;126,130 Clinic must be assoicated with the selected location, if one was selected
IF $GET(ECLOC)
IF ECLOC'=$$GET1^DIQ(44,CLN,"3.5:.07","I")
QUIT
+17 SET ERR=0
IF $DATA(^SC(CLN,"I"))
Begin DoDot:3
+18 SET INACT=$PIECE(^SC(CLN,"I"),U)
SET REACT=$PIECE(^SC(CLN,"I"),U,2)
+19 IF INACT
Begin DoDot:4
+20 IF REACT=""
if ECDT'<INACT
SET ERR=1
QUIT
+21 IF ECDT'<INACT
IF ECDT<REACT
SET ERR=1
QUIT
End DoDot:4
IF ERR
QUIT
+22 ;I REACT,ECDT<REACT S ERR=1 removed in EC*110 - BGP
End DoDot:3
IF ERR
QUIT
+23 ;126 Get clinic and stop code zero node for selected clinic
SET ECNOD=$GET(^ECX(728.44,CLN,0))
+24 ;S CNT=CNT+1,^TMP($J,"ECFIND",CNT)=CLN_U_$P(NOD,U)_U_$P(ECNOD,U,2)_U_$P(ECNOD,U,3)_U_$P($G(^ECX(728.441,+$P(ECNOD,U,8),0)),U) ;126 Add stop code, credit stop, and char4 code
+25 ;152 Only valid clinics are added to the list
IF $PIECE(ECNOD,U,2)'=""
Begin DoDot:3
+26 ;
SET ECRES=$$CLNCK^SDUTL2(CLN,0)
IF 'ECRES
QUIT
+27 ;126 Add stop code, credit stop, and char4 code
SET CNT=CNT+1
SET ^TMP($JOB,"ECFIND",CNT)=CLN_U_$PIECE(NOD,U)_U_$PIECE(ECNOD,U,2)_U_$PIECE(ECNOD,U,3)_U_$PIECE($GET(^ECX(728.441,+$PIECE(ECNOD,U,8),0)),U)
End DoDot:3
End DoDot:2
End DoDot:1
+28 QUIT
CSTCTR ;Search for cost centers (File #420.1)
+1 NEW ECNULL,INDX,STR,NSTR,I
+2 SET $PIECE(ECNULL," ",7)=" "
SET INDX="B"
+3 IF $EXTRACT(ECSTR)?.N
IF $LENGTH(ECSTR)<7
SET ECSTR=ECSTR_$EXTRACT(ECNULL,1,7-$LENGTH(ECSTR))
+4 ;truncate for x-ref
IF $LENGTH($PIECE(ECSTR," "))=6
IF $PIECE(ECSTR," ",2)?.A
Begin DoDot:1
+5 SET ECSTR=$PIECE(ECSTR," ")_" "_$EXTRACT($PIECE(ECSTR," ",2,999),1,22)
End DoDot:1
+6 IF $EXTRACT(ECSTR)?.A
SET INDX="C"
SET (STR,NSTR)=""
Begin DoDot:1
+7 FOR I=1:1
SET STR=$PIECE(ECSTR," ",I)
if STR=""
QUIT
Begin DoDot:2
+8 SET STR=$EXTRACT(STR)_$TRANSLATE($EXTRACT(STR,2,9999),"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
+9 SET NSTR=NSTR_STR
End DoDot:2
End DoDot:1
SET ECSTR=NSTR
+10 DO LISTDIC(ECFIL,"",.01,ECORD,ECNUM,ECSTR,"",INDX,"I '$P(^(0),U,2)","","^TMP(""ECSRCH"",$J)","ECER")
+11 QUIT
SERVC ;Search for services (File #49)
+1 DO LISTDIC(ECFIL,"",.01,ECORD,ECNUM,ECSTR,"","","","","^TMP(""ECSRCH"",$J)","ECER")
+2 QUIT
MEDSPC ;Search for medical specialty (File #723)
+1 DO LISTDIC(ECFIL,"",.01,ECORD,ECNUM,ECSTR,"","","","","^TMP(""ECSRCH"",$J)","ECER")
+2 QUIT
STPCDE ;Search for associated stop code (File #40.7)
+1 ;139
NEW ECNT,INDX,ECNUL,STR,IEN,SCRN
+2 SET $PIECE(ECNUL," ",30)=" "
SET INDX="B"
SET ECNT=0
SET ECSTR=$PIECE(ECSTR,"~")
+3 ;131 If number sent, remove / and replace with 0
IF +ECSTR
IF ECSTR["/"
SET ECSTR=$TRANSLATE(ECSTR,"/",0)
if ECSTR>0
SET ECSTR=ECSTR-1
+4 IF +ECSTR
IF +ECSTR?.N
SET INDX="C"
SET IEN=0
Begin DoDot:1
+5 SET ECSTR=$ORDER(^DIC(40.7,INDX,+ECSTR))
IF ECSTR=""
QUIT
+6 FOR
SET IEN=$ORDER(^DIC(40.7,INDX,ECSTR,IEN))
if 'IEN
QUIT
Begin DoDot:2
+7 ;07/27/09 llh added checks on piece 2 and 6
+8 ;126 allow for searches for primary or secondary
SET STR=$GET(^DIC(40.7,IEN,0))
IF ($PIECE(STR,U,3)'=""&($PIECE(STR,U,3)'>DT))!($PIECE(STR,U,6)=$SELECT($GET(ECTYPE)="":"S",1:"P"))!($PIECE(STR,U,6)="")!($LENGTH($PIECE(STR,U,2))'=3)
QUIT
+9 ;139 If setting up OOS DSS unit, only show OOS related stop codes
IF $GET(ECOOS)="OOS"
IF '$$EX^SDCOU2(IEN,$$NOW^XLFDT)
QUIT
+10 SET STR=$EXTRACT($PIECE(STR,U),1,30)_" ["_$JUSTIFY($PIECE(STR,U,2),3,0)_"]"_U_$PIECE(STR,U,2)_U_IEN
+11 SET ECNT=ECNT+1
SET ^TMP($JOB,"ECFIND",ECNT)=STR
End DoDot:2
IF ECNT>(ECNUM-1)
QUIT
End DoDot:1
QUIT
+12 ;added validation checks here as well
+13 ;139
SET SCRN="I $P(^(0),U,3)=""""!($P(^(0),U,3)'<DT)&($L($P(^(0),U,2))=3)&(($P(^(0),U,6)=$S($G(ECTYPE)="""":""P"",1:""S""))!($P(^(0),U,6)=""E""))"_$SELECT(ECOOS="OOS":" I $$EX^SDCOU2(Y,$$NOW^XLFDT)",1:"")
+14 ;126,139
DO LISTDIC(ECFIL,"",".01;1",ECORD,ECNUM,ECSTR,"",INDX,SCRN,"","^TMP(""ECSRCH"",$J)","ECER")
+15 SET ECNT=0
+16 FOR
SET ECNT=$ORDER(^TMP("ECSRCH",$JOB,"DILIST","ID",ECNT))
if 'ECNT
QUIT
Begin DoDot:1
+17 SET STR=$GET(^TMP("ECSRCH",$JOB,"DILIST","ID",ECNT,.01))_U_$GET(^(1))
+18 SET STR=$EXTRACT($PIECE(STR,U),1,30)_" ["_$JUSTIFY($PIECE(STR,U,2),3,0)_"]"_U_$PIECE(STR,U,2)
+19 SET ^TMP($JOB,"ECFIND",ECNT)=STR_U_^TMP("ECSRCH",$JOB,"DILIST",2,ECNT)
End DoDot:1
+20 QUIT
DUNT ;Search for DSS unit (File #724)
+1 NEW ECNT,SNDPCE
+2 DO LISTDIC(ECFIL,"",".01;10;13",ECORD,ECNUM,ECSTR,"","","I '$P(^(0),""^"",6),$P(^(0),U,8)","","^TMP(""ECSRCH"",$J)","ECER")
+3 SET ECNT=0
+4 FOR
SET ECNT=$ORDER(^TMP("ECSRCH",$JOB,"DILIST","ID",ECNT))
if 'ECNT
QUIT
Begin DoDot:1
+5 SET SNDPCE=$GET(^TMP("ECSRCH",$JOB,"DILIST","ID",ECNT,13))
+6 ;139 Send all records enables clinic selection, else no clinic
SET SNDPCE=$SELECT(SNDPCE="A":1,1:0)
+7 SET ^TMP($JOB,"ECFIND",ECNT)=$GET(^TMP("ECSRCH",$JOB,"DILIST","ID",ECNT,.01))_U_^TMP("ECSRCH",$JOB,"DILIST",2,ECNT)_U_$GET(^TMP("ECSRCH",$JOB,"DILIST","ID",ECNT,10))_U_SNDPCE
End DoDot:1
+8 QUIT
ECAT ;Search for Category (File #726)
+1 DO LISTDIC(ECFIL,"",.01,ECORD,ECNUM,ECSTR,"","","I $P(^(0),""^"",3)=""""!($P(^(0),U,3)>DT)","","^TMP(""ECSRCH"",$J)","ECER")
+2 QUIT
LOC ;Search for Location (File #4)
+1 DO LISTDIC(ECFIL,"",.01,ECORD,ECNUM,ECSTR,"","","I $G(^(""EC""))","","^TMP(""ECSRCH"",$J)","ECER")
+2 QUIT
LISTDIC(ECFL,ECIEN,ECFLD,ECFLG,ECNUM,ECFRM,ECPRT,ECINDX,ECSCN,ECIND,ECTG,ECER) ;
+1 ;Produces a list of records in a file base on search string
+2 NEW DIC
+3 DO LIST^DIC(ECFL,ECIEN,ECFLD,ECFLG,ECNUM,ECFRM,ECPRT,ECINDX,ECSCN,ECIND,ECTG,ECER)
+4 KILL ECFL,ECIEN,ECFLD,ECFLG,ECNUM,ECFRM,ECPRT,ECINDX,ECSCN,ECID
+5 QUIT
SORT ;Extracts data to be returned to broker
+1 NEW ECNT,STR
+2 SET ECNT=0
+3 FOR
SET ECNT=$ORDER(^TMP("ECSRCH",$JOB,"DILIST","ID",ECNT))
if 'ECNT
QUIT
Begin DoDot:1
+4 SET ^TMP($JOB,"ECFIND",ECNT)=$GET(^TMP("ECSRCH",$JOB,"DILIST","ID",ECNT,.01))_U_^TMP("ECSRCH",$JOB,"DILIST",2,ECNT)
End DoDot:1
+5 QUIT
+6 ;
CHAR4 ;126, returns list of CHAR4 codes from the NATIONAL CLINIC file (#728.441)
+1 DO LISTDIC(ECFIL,"",.01,ECORD,ECNUM,ECSTR,"","","I $P($G(^(2)),""^"")=""""!($P($G(^(2)),""^"")>DT)","","^TMP(""ECSRCH"",$J)","ECER")
