- ECUMRPC2 ;ALB/JAM - Event Capture Management Broker Utils ;12/22/21 18:54
- ;;2.0;EVENT CAPTURE;**25,30,42,46,47,49,75,72,95,114,134,156**;8 May 96;Build 28
- ;
- ; Reference to $$SINFO^ICDEX supported by ICR #5747
- ; Reference to $$ICDDX^ICDEX supported by ICR #5747
- ; Reference to ^DIC(4) supported by ICR #10090
- ; Reference to ^TMP supported by SACC 2.3.2.5.1
- ; Reference to FIND^DIC supported by Fileman API #2051
- ; Reference to GET^XUA4A72 supported by ICR #1625
- ; Reference to XLFDT: $$FMADD, $$NOW supported by ICR #10103
- ; Reference to ^%ZTLOAD supported by ICR #10063
- ;
- GLOC(RESULTS,ECARY) ;
- ;
- ;This broker entry point returns all active Event Capture locations
- ; RPC: EC GETLOC
- ;INPUTS ECARY - Contains the following subscripted elements
- ; STAT - Active or inactive locations (optional)
- ; A-ctive (default), I-nactive, B-oth
- ;
- ;OUTPUTS RESULTS - The array of active Event Capture locations.
- ; PIECE - Description
- ; 1 Location IEN
- ; 2 LOC description
- ; 3 State Abbreviation
- ; 4 Current Location Flag
- ; 5 Facility Type
- ; 6 Station Number
- N LOC,STAT,CNT,CLOC,ST,NODE,ACT,ECLOC,ELOC,ECFT,ECSN
- D SETENV^ECUMRPC
- K ^TMP($J,"ECLOCATION")
- S STAT=$P($G(ECARY),U),(CNT,LOC)=0,ACT=0 S:STAT="" STAT="A"
- D GETLOC^ECL(.ECLOC)
- F S LOC=$O(ECLOC(LOC)) Q:'LOC S ELOC($P(ECLOC(LOC),U,2))=""
- S LOC=0
- F S LOC=$O(^DIC(4,LOC)) Q:'LOC S NODE=$G(^DIC(4,LOC,0)) I NODE'="" D
- . S ACT=0 ;134 Reset status before each record
- . I $P(NODE,U)="" Q
- . I ($P(NODE,U,11)="I")!($P($G(^DIC(4,LOC,99)),U,4)) S ACT=1
- . I $S(STAT="A"&(ACT):1,STAT="I"&('ACT):1,1:0) Q
- . S CLOC=$D(ELOC(LOC)),CLOC=$S(CLOC:"YES",1:"")
- . S CNT=CNT+1,ST=$P(NODE,U,2) S:ST'="" ST=$$GET1^DIQ(5,ST,1,"I")
- . S ECFT=$P($G(^DIC(4.1,+$G(^DIC(4,LOC,3)),0)),U)
- . S ECSN=$P($G(^DIC(4,LOC,99)),U)
- . S ^TMP($J,"ECLOCATION",CNT)=LOC_U_$P(NODE,U)_U_ST_U_CLOC_U_ECFT_U_ECSN
- S RESULTS=$NA(^TMP($J,"ECLOCATION"))
- Q
- CPTFND(RESULTS,ECARY) ;
- ;
- ;This broker entry point does a search on a CPT string and returns
- ;a list of matches from file #81
- ; RPC: EC GETCPTLST
- ;INPUTS ECARY - Contains the following subscripted elements
- ; CPTSTR - CPT search string
- ;
- ;OUTPUTS RESULTS - The array of cpt codes. Data pieces as follows:-
- ; CPT ien^CPT code^Name
- ;
- N CPTSTR,ECNT,DIC,ECTG,ECER
- D SETENV^ECUMRPC
- S CPTSTR=$P(ECARY,U),ECNT=0 I CPTSTR="" Q
- K ^TMP($J,"ECPTSRCH"),^TMP("ECCPT",$J)
- D CPTSRH(81,CPTSTR)
- F S ECNT=$O(^TMP("ECCPT",$J,"DILIST","ID",ECNT)) Q:'ECNT D
- .S ^TMP($J,"ECPTSRCH",ECNT)=$G(^TMP("ECCPT",$J,"DILIST",2,ECNT))_U_^TMP("ECCPT",$J,"DILIST","ID",ECNT,.01)_U_^TMP("ECCPT",$J,"DILIST","ID",ECNT,2)
- K ^TMP("ECCPT",$J)
- S RESULTS=$NA(^TMP($J,"ECPTSRCH"))
- Q
- ;
- PXFND(RESULTS,ECARY) ;
- ;
- ;This broker entry point does a search on a procedure string and returns
- ;a list of matches from file #81 and/or #725
- ; RPC: EC GETPXLST
- ;INPUTS ECARY - Contains the following subscripted elements
- ; PXSTR - Procedure search string
- ;
- ;OUTPUTS RESULTS - The array of procedures. Data pieces as follows:-
- ; Procedure ien^Procedure code Procedure Name
- ;
- N CPTSTR,ECNT,DIC,ECX,CNT,ECTG,ECER,PXSTR,ECSTR
- D SETENV^ECUMRPC
- S PXSTR=$P(ECARY,U),ECNT=0 I PXSTR="" Q
- K ^TMP($J,"ECPXSRCH"),^TMP("ECCPT",$J),^TMP("ECCPT1",$J)
- D
- . I $P(PXSTR,".")="A" D CPTSRH(81,$P(PXSTR,".",2)) Q
- . I $P(PXSTR,".")="B" D CPTSRH(725,$P(PXSTR,".",2)) Q
- . F ECX=81,725 D CPTSRH(ECX,PXSTR)
- F S ECNT=$O(^TMP("ECCPT",$J,"DILIST","ID",ECNT)) Q:'ECNT D
- .S ECID=$G(^TMP("ECCPT",$J,"DILIST",2,ECNT))_";ICPT("
- .S ECSTR=^TMP("ECCPT",$J,"DILIST","ID",ECNT,.01)_" "_^(2)
- .S ^TMP($J,"ECPXSRCH",ECNT)=ECID_U_ECSTR
- S ECNT=0,CNT=+$O(^TMP($J,"ECPXSRCH","A"),-1)
- F S ECNT=$O(^TMP("ECCPT1",$J,"DILIST","ID",ECNT)) Q:'ECNT D
- .S CNT=CNT+1,ECID=$G(^TMP("ECCPT1",$J,"DILIST",2,ECNT))_";EC(725,"
- .S ECSTR=^TMP("ECCPT1",$J,"DILIST","ID",ECNT,1)_" "_^(.01)
- .S ^TMP($J,"ECPXSRCH",CNT)=ECID_U_ECSTR
- K ^TMP("ECCPT",$J),^TMP("ECCPT1",$J)
- S RESULTS=$NA(^TMP($J,"ECPXSRCH"))
- Q
- CPTSRH(FILE,CPTSTR) ;Searches either file 81 or 725 for a CPT string
- I FILE=81 D
- .D FINDIC(81,"",".01;2","M",CPTSTR,100,"","I $P($$CPT^ICPTCOD(+Y),""^"",7)","","^TMP(""ECCPT"",$J)")
- I FILE=725 D
- .D FINDIC(725,"",".01;1","M",CPTSTR,100,"","I '$P(^(0),""^"",3)","","^TMP(""ECCPT1"",$J)")
- Q
- FINDIC(ECFL,ECIEN,ECFLD,ECFLG,ECVAL,ECN,ECINDX,ECSCN,ECID,ECTG,ECER) ;
- ;Find records in a file base on search string
- S ECER=$G(ECER)
- D FIND^DIC(ECFL,ECIEN,ECFLD,ECFLG,ECVAL,ECN,ECINDX,ECSCN,ECID,ECTG,ECER)
- K ECFL,ECIEN,ECFLD,ECFLG,ECVAL,ECN,ECINDX,ECSCN,ECID
- Q
- PROV(ECNUM) ;Return a set of providers from the NEW PERSON file
- ;Input Variables:-
- ; ECNUM - # of records to return
- ; FROM - text to $O from
- ; DATE - checks for an active person class on this date (optional)
- ; ECDIR - $O direction
- ; KEY - screen users by security key (optional)
- ; REPORT - Set to "R" to get all entries from file 200, "NLP" if
- ; getting list of users who don't have a person class
- ; and set to blank if only users with a person class should
- ; be returned.
- ; ECDSS - IEN of DSS unit
- ;
- ;Output Variables:-
- ; ^TMP($J,"ECFIND",1..n - returned array
- ; IEN of file 200^Provider Name^occupation^specialty^subspecialty
- ;
- N I,IEN,CNT,FROM,DATE,ECUTN,ECDSS S I=0,CNT=$S(+$G(ECNUM)>0:ECNUM,1:44) ;134
- S FROM=$P(ECSTR,"|"),DATE=$P(ECSTR,"|",2),REPORT=$P(ECSTR,"|",3),ECDSS=$P(ECSTR,"|",4) ;134 Added DSS unit IEN to parameters
- F Q:I'<CNT S FROM=$O(^VA(200,"B",FROM),ECDIR) Q:FROM="" D
- . S IEN="" F S IEN=$O(^VA(200,"B",FROM,IEN),ECDIR) Q:'IEN D
- . . I IEN<1 Q ;134 Don't include special users postmaster and sharedmail
- . . I REPORT="R" S I=I+1,^TMP($J,"ECFIND",I)=IEN_"^"_FROM_"^" Q
- . . S ECUTN=$$GET^XUA4A72(IEN,DATE)
- . . I REPORT="NLP" S:ECUTN<1&($$ACTIVE^XUSER(IEN)) I=I+1,^TMP($J,"ECFIND",I)=IEN_"^"_FROM_"^" Q ;134, if getting non-licensed providers, return all active users who aren't providers
- . . I DATE>0,ECUTN<1,'$D(^EC(722,"B",IEN)) Q ;134 Allows for users in file 722
- . . I $D(^EC(722,"B",IEN)),$P($G(^ECD(+ECDSS,0)),U,14)'="N" Q ;134 Only add user if they're in the file and the DSS Unit is a 'send no records' type
- . . S I=I+1,^TMP($J,"ECFIND",I)=IEN_"^"_FROM_"^"_$P(ECUTN,"^",2,4)
- Q
- LEX ; returns a list of ICD code from lexicon lookup; called from ECUMRPC1
- ;Input Variables:-
- ; ECSTR - APP|ECX|ECDT
- ; application|Search string|procedure date
- ;
- ;Output Variables:-
- ; ^TMP($J,"ECFIND",1..n - returned array
- ; ICD Code^LEX description^IEN of file 80^IEN of file 757.01
- ;
- N LEX,ILST,I,IEN,ECX,APP,ECDT,ICD,ICDIEN,DIC,ECCS,ECCD,IMP
- S ECX=$P(ECSTR,"|",2),ECDT=$P(ECSTR,"|",3)
- S ECDT=$G(ECDT,DT),DIC="^ICD9("
- ; Determine Active Coding System based on Date Of Interest
- S ECCS=$$SINFO^ICDEX("DIAG",ECDT) ; Supported by ICR #5747
- ;spacebar default for DUZ
- I ECX=" ",+($G(DUZ))>0 S IEN=$G(^DISV(DUZ,DIC)) I +IEN D
- .; Load the ICD code info - Supported by ICR 5747
- .S ECCD=$$ICDDX^ICDEX(IEN,ECDT,+ECCS,"I") S:+ECCD>0 ECX=$P(ECCD,U,2)
- S IMP=$$IMPDATE^LEXU("10D"),APP=$S(ECDT<IMP:"ICD",1:"10D") ; Supported by ICR 5679
- K ^TMP("LEXSCH",$J)
- D CONFIG^LEXSET(APP,APP,ECDT) ;LEX DBIA1577
- D LOOK^LEXA(ECX,APP,1,"",ECDT) ;LEX DBIA2950
- I '$D(LEX("LIST",1)) S ^TMP($J,"ECFIND",1)="0^No matches found." Q
- ;LEX DBIA1573
- S ILST=1,IEN=+LEX("LIST",1)
- D ICD I ICDIEN<0 S ^TMP($J,"ECFIND",1)="0^No matches found." Q
- S ^TMP($J,"ECFIND",ILST)=ICD_U_$P(LEX("LIST",1),U,2)_U_ICDIEN_U_LEX("LIST",1),I=""
- ; ICD10 Changed to maximum of 101 entries
- F S I=$O(^TMP("LEXFND",$J,I)) Q:I'<0!(ILST=101) D
- .; Loop through all the ICD codes
- .S IEN=""
- .F S IEN=$O(^TMP("LEXFND",$J,I,IEN)) Q:'IEN D
- ..D ICD I ICDIEN<0 Q
- ..S ILST=ILST+1
- ..S ^TMP($J,"ECFIND",ILST)=ICD_U_^TMP("LEXFND",$J,I,IEN)_U_ICDIEN_U_IEN
- I $O(^TMP($J,"ECFIND",0))="" S ^TMP($J,"ECFIND",1)="0^No matches found."
- K ^TMP("LEXFND",$J),^TMP("LEXHIT",$J)
- Q
- ;
- ICD ;ICD code
- S ICD=$$ONE^LEXU(IEN,ECDT,APP) ; Supported by ICR 5679, ICD-9 and ICD-10
- S ECCS=$$SINFO^ICDEX("DIAG",ECDT) ; Supported by ICR #5747
- S ICDIEN=+$$ICDDX^ICDEX(ICD,ECDT,+ECCS,"E") ; Supported by ICR #5747
- Q
- ;
- DTPD(RESULTS,ECARY) ;Delete test patient data
- ;134 Section added for deleting test patient data
- ;Input Variable
- ; ECARY - Set to "I" to get information or "D" to delete records
- ;Output variable
- ; RESULT - Returns account info when ECARY is "I" or success
- ; when ECARY is "D"
- ;
- N MODE,ZTRTN,ZTIO,ZTDTH,ZTSK
- S MODE=$P(ECARY,U) Q:MODE=""
- D SETENV^ECUMRPC ;Set up minimal variables for an RPC call
- K ^TMP($J,"ECDELETE") ;Clear TMP global space
- I MODE="I" D S RESULTS=$NA(^TMP($J,"ECDELETE")) Q
- .S $P(^TMP($J,"ECDELETE",0),U)=$S($$PROD^XUPROD=0:"Test",1:"Production") ;Is account a test or production environment
- .S $P(^TMP($J,"ECDELETE",0),U,2)=$S($G(^XMB("NETNAME"))'="":$G(^XMB("NETNAME")),1:"network name undefined") ;Get account/network name
- .S $P(^TMP($J,"ECDELETE",0),U,3)=$S($P($G(^XTMP("ECDELETE","DEL")),U)'="":$$FMTE^XLFDT($P($G(^XTMP("ECDELETE","DEL")),U)),1:"First Time") ;Date deletion last run
- .S $P(^TMP($J,"ECDELETE",0),U,4)=$S($P($G(^XTMP("ECDELETE","DEL")),U,2)'="":$$GET1^DIQ(200,$P($G(^XTMP("ECDELETE","DEL")),U,2)_",",.01),1:"") ;Get name of person who did deletion
- .S $P(^TMP($J,"ECDELETE",0),U,5)=+$P($G(^XTMP("ECDELETE","DEL")),U,3) ;Status of deletion (0 not running, 1 if running)
- ;
- ;If deleting, queue to run in the background
- I MODE="D" D S RESULTS=$NA(^TMP($J,"ECDELETE")) Q
- .S ZTRTN="DEL^ECDTPD",ZTIO="",ZTDTH=$$NOW^XLFDT,ZTDESC="Delete test patient data from Event Capture Patient file (#721)"
- .D ^%ZTLOAD
- .S ^TMP($J,"ECDELETE",0)=$S($G(ZTSK):1,1:0) ;Return 1 if success, otherwise 0
- .I $G(ZTSK) S ^XTMP("ECDELETE",0)=$$FMADD^XLFDT($$DT^XLFDT,730)_"^"_$$DT^XLFDT_"^Info for EC test patient deletion",^XTMP("ECDELETE","DEL")=$$NOW^XLFDT_"^"_$G(DUZ,0)_"^"_1
- .Q
- Q
- ;
- ECDEL(RESULTS,ECARY) ;156 - Broker entry point to delete data in Event Capture files
- ;This RPC is called when delete an entry in Event Capture files
- ; RPC: EC DELETE ENTRY
- ;INPUTS ECARY - array with data to be deleted
- ; ECARY("ECFILE")=file #
- ; ECARY("IEN")=ien to be deleted from the file
- ;
- ;OUTPUTS RESULTS - Success or failure to file
- ;
- N ECFILE,ECDUZ
- D SETENV^ECUMRPC
- D PARSE^ECFLRPC
- K ^TMP($J,"ECMSG")
- I $G(ECFILE)="" S ^TMP($J,"ECMSG",1)="0^File Not defined" D END^ECFLRPC Q
- S:$G(DUZ) ECDUZ=DUZ
- I ECFILE=720.3 D DELECSR^ECMDECS,END^ECFLRPC Q
- I ECFILE=724 D DELDSS^ECMDDSSU,END^ECFLRPC Q
- S ^TMP($J,"ECMSG",1)="0^Deletion Not Available"
- D KILLVAR^ECFLRPC
- S RESULTS=$NA(^TMP($J,"ECMSG"))
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECUMRPC2 11034 printed Jan 18, 2025@03:00:20 Page 2
- ECUMRPC2 ;ALB/JAM - Event Capture Management Broker Utils ;12/22/21 18:54
- +1 ;;2.0;EVENT CAPTURE;**25,30,42,46,47,49,75,72,95,114,134,156**;8 May 96;Build 28
- +2 ;
- +3 ; Reference to $$SINFO^ICDEX supported by ICR #5747
- +4 ; Reference to $$ICDDX^ICDEX supported by ICR #5747
- +5 ; Reference to ^DIC(4) supported by ICR #10090
- +6 ; Reference to ^TMP supported by SACC 2.3.2.5.1
- +7 ; Reference to FIND^DIC supported by Fileman API #2051
- +8 ; Reference to GET^XUA4A72 supported by ICR #1625
- +9 ; Reference to XLFDT: $$FMADD, $$NOW supported by ICR #10103
- +10 ; Reference to ^%ZTLOAD supported by ICR #10063
- +11 ;
- GLOC(RESULTS,ECARY) ;
- +1 ;
- +2 ;This broker entry point returns all active Event Capture locations
- +3 ; RPC: EC GETLOC
- +4 ;INPUTS ECARY - Contains the following subscripted elements
- +5 ; STAT - Active or inactive locations (optional)
- +6 ; A-ctive (default), I-nactive, B-oth
- +7 ;
- +8 ;OUTPUTS RESULTS - The array of active Event Capture locations.
- +9 ; PIECE - Description
- +10 ; 1 Location IEN
- +11 ; 2 LOC description
- +12 ; 3 State Abbreviation
- +13 ; 4 Current Location Flag
- +14 ; 5 Facility Type
- +15 ; 6 Station Number
- +16 NEW LOC,STAT,CNT,CLOC,ST,NODE,ACT,ECLOC,ELOC,ECFT,ECSN
- +17 DO SETENV^ECUMRPC
- +18 KILL ^TMP($JOB,"ECLOCATION")
- +19 SET STAT=$PIECE($GET(ECARY),U)
- SET (CNT,LOC)=0
- SET ACT=0
- if STAT=""
- SET STAT="A"
- +20 DO GETLOC^ECL(.ECLOC)
- +21 FOR
- SET LOC=$ORDER(ECLOC(LOC))
- if 'LOC
- QUIT
- SET ELOC($PIECE(ECLOC(LOC),U,2))=""
- +22 SET LOC=0
- +23 FOR
- SET LOC=$ORDER(^DIC(4,LOC))
- if 'LOC
- QUIT
- SET NODE=$GET(^DIC(4,LOC,0))
- IF NODE'=""
- Begin DoDot:1
- +24 ;134 Reset status before each record
- SET ACT=0
- +25 IF $PIECE(NODE,U)=""
- QUIT
- +26 IF ($PIECE(NODE,U,11)="I")!($PIECE($GET(^DIC(4,LOC,99)),U,4))
- SET ACT=1
- +27 IF $SELECT(STAT="A"&(ACT):1,STAT="I"&('ACT):1,1:0)
- QUIT
- +28 SET CLOC=$DATA(ELOC(LOC))
- SET CLOC=$SELECT(CLOC:"YES",1:"")
- +29 SET CNT=CNT+1
- SET ST=$PIECE(NODE,U,2)
- if ST'=""
- SET ST=$$GET1^DIQ(5,ST,1,"I")
- +30 SET ECFT=$PIECE($GET(^DIC(4.1,+$GET(^DIC(4,LOC,3)),0)),U)
- +31 SET ECSN=$PIECE($GET(^DIC(4,LOC,99)),U)
- +32 SET ^TMP($JOB,"ECLOCATION",CNT)=LOC_U_$PIECE(NODE,U)_U_ST_U_CLOC_U_ECFT_U_ECSN
- End DoDot:1
- +33 SET RESULTS=$NAME(^TMP($JOB,"ECLOCATION"))
- +34 QUIT
- CPTFND(RESULTS,ECARY) ;
- +1 ;
- +2 ;This broker entry point does a search on a CPT string and returns
- +3 ;a list of matches from file #81
- +4 ; RPC: EC GETCPTLST
- +5 ;INPUTS ECARY - Contains the following subscripted elements
- +6 ; CPTSTR - CPT search string
- +7 ;
- +8 ;OUTPUTS RESULTS - The array of cpt codes. Data pieces as follows:-
- +9 ; CPT ien^CPT code^Name
- +10 ;
- +11 NEW CPTSTR,ECNT,DIC,ECTG,ECER
- +12 DO SETENV^ECUMRPC
- +13 SET CPTSTR=$PIECE(ECARY,U)
- SET ECNT=0
- IF CPTSTR=""
- QUIT
- +14 KILL ^TMP($JOB,"ECPTSRCH"),^TMP("ECCPT",$JOB)
- +15 DO CPTSRH(81,CPTSTR)
- +16 FOR
- SET ECNT=$ORDER(^TMP("ECCPT",$JOB,"DILIST","ID",ECNT))
- if 'ECNT
- QUIT
- Begin DoDot:1
- +17 SET ^TMP($JOB,"ECPTSRCH",ECNT)=$GET(^TMP("ECCPT",$JOB,"DILIST",2,ECNT))_U_^TMP("ECCPT",$JOB,"DILIST","ID",ECNT,.01)_U_^TMP("ECCPT",$JOB,"DILIST","ID",ECNT,2)
- End DoDot:1
- +18 KILL ^TMP("ECCPT",$JOB)
- +19 SET RESULTS=$NAME(^TMP($JOB,"ECPTSRCH"))
- +20 QUIT
- +21 ;
- PXFND(RESULTS,ECARY) ;
- +1 ;
- +2 ;This broker entry point does a search on a procedure string and returns
- +3 ;a list of matches from file #81 and/or #725
- +4 ; RPC: EC GETPXLST
- +5 ;INPUTS ECARY - Contains the following subscripted elements
- +6 ; PXSTR - Procedure search string
- +7 ;
- +8 ;OUTPUTS RESULTS - The array of procedures. Data pieces as follows:-
- +9 ; Procedure ien^Procedure code Procedure Name
- +10 ;
- +11 NEW CPTSTR,ECNT,DIC,ECX,CNT,ECTG,ECER,PXSTR,ECSTR
- +12 DO SETENV^ECUMRPC
- +13 SET PXSTR=$PIECE(ECARY,U)
- SET ECNT=0
- IF PXSTR=""
- QUIT
- +14 KILL ^TMP($JOB,"ECPXSRCH"),^TMP("ECCPT",$JOB),^TMP("ECCPT1",$JOB)
- +15 Begin DoDot:1
- +16 IF $PIECE(PXSTR,".")="A"
- DO CPTSRH(81,$PIECE(PXSTR,".",2))
- QUIT
- +17 IF $PIECE(PXSTR,".")="B"
- DO CPTSRH(725,$PIECE(PXSTR,".",2))
- QUIT
- +18 FOR ECX=81,725
- DO CPTSRH(ECX,PXSTR)
- End DoDot:1
- +19 FOR
- SET ECNT=$ORDER(^TMP("ECCPT",$JOB,"DILIST","ID",ECNT))
- if 'ECNT
- QUIT
- Begin DoDot:1
- +20 SET ECID=$GET(^TMP("ECCPT",$JOB,"DILIST",2,ECNT))_";ICPT("
- +21 SET ECSTR=^TMP("ECCPT",$JOB,"DILIST","ID",ECNT,.01)_" "_^(2)
- +22 SET ^TMP($JOB,"ECPXSRCH",ECNT)=ECID_U_ECSTR
- End DoDot:1
- +23 SET ECNT=0
- SET CNT=+$ORDER(^TMP($JOB,"ECPXSRCH","A"),-1)
- +24 FOR
- SET ECNT=$ORDER(^TMP("ECCPT1",$JOB,"DILIST","ID",ECNT))
- if 'ECNT
- QUIT
- Begin DoDot:1
- +25 SET CNT=CNT+1
- SET ECID=$GET(^TMP("ECCPT1",$JOB,"DILIST",2,ECNT))_";EC(725,"
- +26 SET ECSTR=^TMP("ECCPT1",$JOB,"DILIST","ID",ECNT,1)_" "_^(.01)
- +27 SET ^TMP($JOB,"ECPXSRCH",CNT)=ECID_U_ECSTR
- End DoDot:1
- +28 KILL ^TMP("ECCPT",$JOB),^TMP("ECCPT1",$JOB)
- +29 SET RESULTS=$NAME(^TMP($JOB,"ECPXSRCH"))
- +30 QUIT
- CPTSRH(FILE,CPTSTR) ;Searches either file 81 or 725 for a CPT string
- +1 IF FILE=81
- Begin DoDot:1
- +2 DO FINDIC(81,"",".01;2","M",CPTSTR,100,"","I $P($$CPT^ICPTCOD(+Y),""^"",7)","","^TMP(""ECCPT"",$J)")
- End DoDot:1
- +3 IF FILE=725
- Begin DoDot:1
- +4 DO FINDIC(725,"",".01;1","M",CPTSTR,100,"","I '$P(^(0),""^"",3)","","^TMP(""ECCPT1"",$J)")
- End DoDot:1
- +5 QUIT
- FINDIC(ECFL,ECIEN,ECFLD,ECFLG,ECVAL,ECN,ECINDX,ECSCN,ECID,ECTG,ECER) ;
- +1 ;Find records in a file base on search string
- +2 SET ECER=$GET(ECER)
- +3 DO FIND^DIC(ECFL,ECIEN,ECFLD,ECFLG,ECVAL,ECN,ECINDX,ECSCN,ECID,ECTG,ECER)
- +4 KILL ECFL,ECIEN,ECFLD,ECFLG,ECVAL,ECN,ECINDX,ECSCN,ECID
- +5 QUIT
- PROV(ECNUM) ;Return a set of providers from the NEW PERSON file
- +1 ;Input Variables:-
- +2 ; ECNUM - # of records to return
- +3 ; FROM - text to $O from
- +4 ; DATE - checks for an active person class on this date (optional)
- +5 ; ECDIR - $O direction
- +6 ; KEY - screen users by security key (optional)
- +7 ; REPORT - Set to "R" to get all entries from file 200, "NLP" if
- +8 ; getting list of users who don't have a person class
- +9 ; and set to blank if only users with a person class should
- +10 ; be returned.
- +11 ; ECDSS - IEN of DSS unit
- +12 ;
- +13 ;Output Variables:-
- +14 ; ^TMP($J,"ECFIND",1..n - returned array
- +15 ; IEN of file 200^Provider Name^occupation^specialty^subspecialty
- +16 ;
- +17 ;134
- NEW I,IEN,CNT,FROM,DATE,ECUTN,ECDSS
- SET I=0
- SET CNT=$SELECT(+$GET(ECNUM)>0:ECNUM,1:44)
- +18 ;134 Added DSS unit IEN to parameters
- SET FROM=$PIECE(ECSTR,"|")
- SET DATE=$PIECE(ECSTR,"|",2)
- SET REPORT=$PIECE(ECSTR,"|",3)
- SET ECDSS=$PIECE(ECSTR,"|",4)
- +19 FOR
- if I'<CNT
- QUIT
- SET FROM=$ORDER(^VA(200,"B",FROM),ECDIR)
- if FROM=""
- QUIT
- Begin DoDot:1
- +20 SET IEN=""
- FOR
- SET IEN=$ORDER(^VA(200,"B",FROM,IEN),ECDIR)
- if 'IEN
- QUIT
- Begin DoDot:2
- +21 ;134 Don't include special users postmaster and sharedmail
- IF IEN<1
- QUIT
- +22 IF REPORT="R"
- SET I=I+1
- SET ^TMP($JOB,"ECFIND",I)=IEN_"^"_FROM_"^"
- QUIT
- +23 SET ECUTN=$$GET^XUA4A72(IEN,DATE)
- +24 ;134, if getting non-licensed providers, return all active users who aren't providers
- IF REPORT="NLP"
- if ECUTN<1&($$ACTIVE^XUSER(IEN))
- SET I=I+1
- SET ^TMP($JOB,"ECFIND",I)=IEN_"^"_FROM_"^"
- QUIT
- +25 ;134 Allows for users in file 722
- IF DATE>0
- IF ECUTN<1
- IF '$DATA(^EC(722,"B",IEN))
- QUIT
- +26 ;134 Only add user if they're in the file and the DSS Unit is a 'send no records' type
- IF $DATA(^EC(722,"B",IEN))
- IF $PIECE($GET(^ECD(+ECDSS,0)),U,14)'="N"
- QUIT
- +27 SET I=I+1
- SET ^TMP($JOB,"ECFIND",I)=IEN_"^"_FROM_"^"_$PIECE(ECUTN,"^",2,4)
- End DoDot:2
- End DoDot:1
- +28 QUIT
- LEX ; returns a list of ICD code from lexicon lookup; called from ECUMRPC1
- +1 ;Input Variables:-
- +2 ; ECSTR - APP|ECX|ECDT
- +3 ; application|Search string|procedure date
- +4 ;
- +5 ;Output Variables:-
- +6 ; ^TMP($J,"ECFIND",1..n - returned array
- +7 ; ICD Code^LEX description^IEN of file 80^IEN of file 757.01
- +8 ;
- +9 NEW LEX,ILST,I,IEN,ECX,APP,ECDT,ICD,ICDIEN,DIC,ECCS,ECCD,IMP
- +10 SET ECX=$PIECE(ECSTR,"|",2)
- SET ECDT=$PIECE(ECSTR,"|",3)
- +11 SET ECDT=$GET(ECDT,DT)
- SET DIC="^ICD9("
- +12 ; Determine Active Coding System based on Date Of Interest
- +13 ; Supported by ICR #5747
- SET ECCS=$$SINFO^ICDEX("DIAG",ECDT)
- +14 ;spacebar default for DUZ
- +15 IF ECX=" "
- IF +($GET(DUZ))>0
- SET IEN=$GET(^DISV(DUZ,DIC))
- IF +IEN
- Begin DoDot:1
- +16 ; Load the ICD code info - Supported by ICR 5747
- +17 SET ECCD=$$ICDDX^ICDEX(IEN,ECDT,+ECCS,"I")
- if +ECCD>0
- SET ECX=$PIECE(ECCD,U,2)
- End DoDot:1
- +18 ; Supported by ICR 5679
- SET IMP=$$IMPDATE^LEXU("10D")
- SET APP=$SELECT(ECDT<IMP:"ICD",1:"10D")
- +19 KILL ^TMP("LEXSCH",$JOB)
- +20 ;LEX DBIA1577
- DO CONFIG^LEXSET(APP,APP,ECDT)
- +21 ;LEX DBIA2950
- DO LOOK^LEXA(ECX,APP,1,"",ECDT)
- +22 IF '$DATA(LEX("LIST",1))
- SET ^TMP($JOB,"ECFIND",1)="0^No matches found."
- QUIT
- +23 ;LEX DBIA1573
- +24 SET ILST=1
- SET IEN=+LEX("LIST",1)
- +25 DO ICD
- IF ICDIEN<0
- SET ^TMP($JOB,"ECFIND",1)="0^No matches found."
- QUIT
- +26 SET ^TMP($JOB,"ECFIND",ILST)=ICD_U_$PIECE(LEX("LIST",1),U,2)_U_ICDIEN_U_LEX("LIST",1)
- SET I=""
- +27 ; ICD10 Changed to maximum of 101 entries
- +28 FOR
- SET I=$ORDER(^TMP("LEXFND",$JOB,I))
- if I'<0!(ILST=101)
- QUIT
- Begin DoDot:1
- +29 ; Loop through all the ICD codes
- +30 SET IEN=""
- +31 FOR
- SET IEN=$ORDER(^TMP("LEXFND",$JOB,I,IEN))
- if 'IEN
- QUIT
- Begin DoDot:2
- +32 DO ICD
- IF ICDIEN<0
- QUIT
- +33 SET ILST=ILST+1
- +34 SET ^TMP($JOB,"ECFIND",ILST)=ICD_U_^TMP("LEXFND",$JOB,I,IEN)_U_ICDIEN_U_IEN
- End DoDot:2
- End DoDot:1
- +35 IF $ORDER(^TMP($JOB,"ECFIND",0))=""
- SET ^TMP($JOB,"ECFIND",1)="0^No matches found."
- +36 KILL ^TMP("LEXFND",$JOB),^TMP("LEXHIT",$JOB)
- +37 QUIT
- +38 ;
- ICD ;ICD code
- +1 ; Supported by ICR 5679, ICD-9 and ICD-10
- SET ICD=$$ONE^LEXU(IEN,ECDT,APP)
- +2 ; Supported by ICR #5747
- SET ECCS=$$SINFO^ICDEX("DIAG",ECDT)
- +3 ; Supported by ICR #5747
- SET ICDIEN=+$$ICDDX^ICDEX(ICD,ECDT,+ECCS,"E")
- +4 QUIT
- +5 ;
- DTPD(RESULTS,ECARY) ;Delete test patient data
- +1 ;134 Section added for deleting test patient data
- +2 ;Input Variable
- +3 ; ECARY - Set to "I" to get information or "D" to delete records
- +4 ;Output variable
- +5 ; RESULT - Returns account info when ECARY is "I" or success
- +6 ; when ECARY is "D"
- +7 ;
- +8 NEW MODE,ZTRTN,ZTIO,ZTDTH,ZTSK
- +9 SET MODE=$PIECE(ECARY,U)
- if MODE=""
- QUIT
- +10 ;Set up minimal variables for an RPC call
- DO SETENV^ECUMRPC
- +11 ;Clear TMP global space
- KILL ^TMP($JOB,"ECDELETE")
- +12 IF MODE="I"
- Begin DoDot:1
- +13 ;Is account a test or production environment
- SET $PIECE(^TMP($JOB,"ECDELETE",0),U)=$SELECT($$PROD^XUPROD=0:"Test",1:"Production")
- +14 ;Get account/network name
- SET $PIECE(^TMP($JOB,"ECDELETE",0),U,2)=$SELECT($GET(^XMB("NETNAME"))'="":$GET(^XMB("NETNAME")),1:"network name undefined")
- +15 ;Date deletion last run
- SET $PIECE(^TMP($JOB,"ECDELETE",0),U,3)=$SELECT($PIECE($GET(^XTMP("ECDELETE","DEL")),U)'="":$$FMTE^XLFDT($PIECE($GET(^XTMP("ECDELETE","DEL")),U)),1:"First Time")
- +16 ;Get name of person who did deletion
- SET $PIECE(^TMP($JOB,"ECDELETE",0),U,4)=$SELECT($PIECE($GET(^XTMP("ECDELETE","DEL")),U,2)'="":$$GET1^DIQ(200,$PIECE($GET(^XTMP("ECDELETE","DEL")),U,2)_",",.01),1:"")
- +17 ;Status of deletion (0 not running, 1 if running)
- SET $PIECE(^TMP($JOB,"ECDELETE",0),U,5)=+$PIECE($GET(^XTMP("ECDELETE","DEL")),U,3)
- End DoDot:1
- SET RESULTS=$NAME(^TMP($JOB,"ECDELETE"))
- QUIT
- +18 ;
- +19 ;If deleting, queue to run in the background
- +20 IF MODE="D"
- Begin DoDot:1
- +21 SET ZTRTN="DEL^ECDTPD"
- SET ZTIO=""
- SET ZTDTH=$$NOW^XLFDT
- SET ZTDESC="Delete test patient data from Event Capture Patient file (#721)"
- +22 DO ^%ZTLOAD
- +23 ;Return 1 if success, otherwise 0
- SET ^TMP($JOB,"ECDELETE",0)=$SELECT($GET(ZTSK):1,1:0)
- +24 IF $GET(ZTSK)
- SET ^XTMP("ECDELETE",0)=$$FMADD^XLFDT($$DT^XLFDT,730)_"^"_$$DT^XLFDT_"^Info for EC test patient deletion"
- SET ^XTMP("ECDELETE","DEL")=$$NOW^XLFDT_"^"_$G(DUZ,0)_"^"_1
- +25 QUIT
- End DoDot:1
- SET RESULTS=$NAME(^TMP($JOB,"ECDELETE"))
- QUIT
- +26 QUIT
- +27 ;
- ECDEL(RESULTS,ECARY) ;156 - Broker entry point to delete data in Event Capture files
- +1 ;This RPC is called when delete an entry in Event Capture files
- +2 ; RPC: EC DELETE ENTRY
- +3 ;INPUTS ECARY - array with data to be deleted
- +4 ; ECARY("ECFILE")=file #
- +5 ; ECARY("IEN")=ien to be deleted from the file
- +6 ;
- +7 ;OUTPUTS RESULTS - Success or failure to file
- +8 ;
- +9 NEW ECFILE,ECDUZ
- +10 DO SETENV^ECUMRPC
- +11 DO PARSE^ECFLRPC
- +12 KILL ^TMP($JOB,"ECMSG")
- +13 IF $GET(ECFILE)=""
- SET ^TMP($JOB,"ECMSG",1)="0^File Not defined"
- DO END^ECFLRPC
- QUIT
- +14 if $GET(DUZ)
- SET ECDUZ=DUZ
- +15 IF ECFILE=720.3
- DO DELECSR^ECMDECS
- DO END^ECFLRPC
- QUIT
- +16 IF ECFILE=724
- DO DELDSS^ECMDDSSU
- DO END^ECFLRPC
- QUIT
- +17 SET ^TMP($JOB,"ECMSG",1)="0^Deletion Not Available"
- +18 DO KILLVAR^ECFLRPC
- +19 SET RESULTS=$NAME(^TMP($JOB,"ECMSG"))
- +20 QUIT