Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ECUMRPC2

ECUMRPC2.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; Reference to $$SINFO^ICDEX supported by ICR #5747
  1. ; Reference to $$ICDDX^ICDEX supported by ICR #5747
  1. ; Reference to ^DIC(4) supported by ICR #10090
  1. ; Reference to ^TMP supported by SACC 2.3.2.5.1
  1. ; Reference to FIND^DIC supported by Fileman API #2051
  1. ; Reference to GET^XUA4A72 supported by ICR #1625
  1. ; Reference to XLFDT: $$FMADD, $$NOW supported by ICR #10103
  1. ; Reference to ^%ZTLOAD supported by ICR #10063
  1. ;
  1. GLOC(RESULTS,ECARY) ;
  1. ;
  1. ;This broker entry point returns all active Event Capture locations
  1. ; RPC: EC GETLOC
  1. ;INPUTS ECARY - Contains the following subscripted elements
  1. ; STAT - Active or inactive locations (optional)
  1. ; A-ctive (default), I-nactive, B-oth
  1. ;
  1. ;OUTPUTS RESULTS - The array of active Event Capture locations.
  1. ; PIECE - Description
  1. ; 1 Location IEN
  1. ; 2 LOC description
  1. ; 3 State Abbreviation
  1. ; 4 Current Location Flag
  1. ; 5 Facility Type
  1. ; 6 Station Number
  1. N LOC,STAT,CNT,CLOC,ST,NODE,ACT,ECLOC,ELOC,ECFT,ECSN
  1. D SETENV^ECUMRPC
  1. K ^TMP($J,"ECLOCATION")
  1. S STAT=$P($G(ECARY),U),(CNT,LOC)=0,ACT=0 S:STAT="" STAT="A"
  1. D GETLOC^ECL(.ECLOC)
  1. F S LOC=$O(ECLOC(LOC)) Q:'LOC S ELOC($P(ECLOC(LOC),U,2))=""
  1. S LOC=0
  1. F S LOC=$O(^DIC(4,LOC)) Q:'LOC S NODE=$G(^DIC(4,LOC,0)) I NODE'="" D
  1. . S ACT=0 ;134 Reset status before each record
  1. . I $P(NODE,U)="" Q
  1. . I ($P(NODE,U,11)="I")!($P($G(^DIC(4,LOC,99)),U,4)) S ACT=1
  1. . I $S(STAT="A"&(ACT):1,STAT="I"&('ACT):1,1:0) Q
  1. . S CLOC=$D(ELOC(LOC)),CLOC=$S(CLOC:"YES",1:"")
  1. . S CNT=CNT+1,ST=$P(NODE,U,2) S:ST'="" ST=$$GET1^DIQ(5,ST,1,"I")
  1. . S ECFT=$P($G(^DIC(4.1,+$G(^DIC(4,LOC,3)),0)),U)
  1. . S ECSN=$P($G(^DIC(4,LOC,99)),U)
  1. . S ^TMP($J,"ECLOCATION",CNT)=LOC_U_$P(NODE,U)_U_ST_U_CLOC_U_ECFT_U_ECSN
  1. S RESULTS=$NA(^TMP($J,"ECLOCATION"))
  1. Q
  1. CPTFND(RESULTS,ECARY) ;
  1. ;
  1. ;This broker entry point does a search on a CPT string and returns
  1. ;a list of matches from file #81
  1. ; RPC: EC GETCPTLST
  1. ;INPUTS ECARY - Contains the following subscripted elements
  1. ; CPTSTR - CPT search string
  1. ;
  1. ;OUTPUTS RESULTS - The array of cpt codes. Data pieces as follows:-
  1. ; CPT ien^CPT code^Name
  1. ;
  1. N CPTSTR,ECNT,DIC,ECTG,ECER
  1. D SETENV^ECUMRPC
  1. S CPTSTR=$P(ECARY,U),ECNT=0 I CPTSTR="" Q
  1. K ^TMP($J,"ECPTSRCH"),^TMP("ECCPT",$J)
  1. D CPTSRH(81,CPTSTR)
  1. F S ECNT=$O(^TMP("ECCPT",$J,"DILIST","ID",ECNT)) Q:'ECNT D
  1. .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)
  1. K ^TMP("ECCPT",$J)
  1. S RESULTS=$NA(^TMP($J,"ECPTSRCH"))
  1. Q
  1. ;
  1. PXFND(RESULTS,ECARY) ;
  1. ;
  1. ;This broker entry point does a search on a procedure string and returns
  1. ;a list of matches from file #81 and/or #725
  1. ; RPC: EC GETPXLST
  1. ;INPUTS ECARY - Contains the following subscripted elements
  1. ; PXSTR - Procedure search string
  1. ;
  1. ;OUTPUTS RESULTS - The array of procedures. Data pieces as follows:-
  1. ; Procedure ien^Procedure code Procedure Name
  1. ;
  1. N CPTSTR,ECNT,DIC,ECX,CNT,ECTG,ECER,PXSTR,ECSTR
  1. D SETENV^ECUMRPC
  1. S PXSTR=$P(ECARY,U),ECNT=0 I PXSTR="" Q
  1. K ^TMP($J,"ECPXSRCH"),^TMP("ECCPT",$J),^TMP("ECCPT1",$J)
  1. D
  1. . I $P(PXSTR,".")="A" D CPTSRH(81,$P(PXSTR,".",2)) Q
  1. . I $P(PXSTR,".")="B" D CPTSRH(725,$P(PXSTR,".",2)) Q
  1. . F ECX=81,725 D CPTSRH(ECX,PXSTR)
  1. F S ECNT=$O(^TMP("ECCPT",$J,"DILIST","ID",ECNT)) Q:'ECNT D
  1. .S ECID=$G(^TMP("ECCPT",$J,"DILIST",2,ECNT))_";ICPT("
  1. .S ECSTR=^TMP("ECCPT",$J,"DILIST","ID",ECNT,.01)_" "_^(2)
  1. .S ^TMP($J,"ECPXSRCH",ECNT)=ECID_U_ECSTR
  1. S ECNT=0,CNT=+$O(^TMP($J,"ECPXSRCH","A"),-1)
  1. F S ECNT=$O(^TMP("ECCPT1",$J,"DILIST","ID",ECNT)) Q:'ECNT D
  1. .S CNT=CNT+1,ECID=$G(^TMP("ECCPT1",$J,"DILIST",2,ECNT))_";EC(725,"
  1. .S ECSTR=^TMP("ECCPT1",$J,"DILIST","ID",ECNT,1)_" "_^(.01)
  1. .S ^TMP($J,"ECPXSRCH",CNT)=ECID_U_ECSTR
  1. K ^TMP("ECCPT",$J),^TMP("ECCPT1",$J)
  1. S RESULTS=$NA(^TMP($J,"ECPXSRCH"))
  1. Q
  1. CPTSRH(FILE,CPTSTR) ;Searches either file 81 or 725 for a CPT string
  1. I FILE=81 D
  1. .D FINDIC(81,"",".01;2","M",CPTSTR,100,"","I $P($$CPT^ICPTCOD(+Y),""^"",7)","","^TMP(""ECCPT"",$J)")
  1. I FILE=725 D
  1. .D FINDIC(725,"",".01;1","M",CPTSTR,100,"","I '$P(^(0),""^"",3)","","^TMP(""ECCPT1"",$J)")
  1. Q
  1. FINDIC(ECFL,ECIEN,ECFLD,ECFLG,ECVAL,ECN,ECINDX,ECSCN,ECID,ECTG,ECER) ;
  1. ;Find records in a file base on search string
  1. S ECER=$G(ECER)
  1. D FIND^DIC(ECFL,ECIEN,ECFLD,ECFLG,ECVAL,ECN,ECINDX,ECSCN,ECID,ECTG,ECER)
  1. K ECFL,ECIEN,ECFLD,ECFLG,ECVAL,ECN,ECINDX,ECSCN,ECID
  1. Q
  1. PROV(ECNUM) ;Return a set of providers from the NEW PERSON file
  1. ;Input Variables:-
  1. ; ECNUM - # of records to return
  1. ; FROM - text to $O from
  1. ; DATE - checks for an active person class on this date (optional)
  1. ; ECDIR - $O direction
  1. ; KEY - screen users by security key (optional)
  1. ; REPORT - Set to "R" to get all entries from file 200, "NLP" if
  1. ; getting list of users who don't have a person class
  1. ; and set to blank if only users with a person class should
  1. ; be returned.
  1. ; ECDSS - IEN of DSS unit
  1. ;
  1. ;Output Variables:-
  1. ; ^TMP($J,"ECFIND",1..n - returned array
  1. ; IEN of file 200^Provider Name^occupation^specialty^subspecialty
  1. ;
  1. N I,IEN,CNT,FROM,DATE,ECUTN,ECDSS S I=0,CNT=$S(+$G(ECNUM)>0:ECNUM,1:44) ;134
  1. S FROM=$P(ECSTR,"|"),DATE=$P(ECSTR,"|",2),REPORT=$P(ECSTR,"|",3),ECDSS=$P(ECSTR,"|",4) ;134 Added DSS unit IEN to parameters
  1. F Q:I'<CNT S FROM=$O(^VA(200,"B",FROM),ECDIR) Q:FROM="" D
  1. . S IEN="" F S IEN=$O(^VA(200,"B",FROM,IEN),ECDIR) Q:'IEN D
  1. . . I IEN<1 Q ;134 Don't include special users postmaster and sharedmail
  1. . . I REPORT="R" S I=I+1,^TMP($J,"ECFIND",I)=IEN_"^"_FROM_"^" Q
  1. . . S ECUTN=$$GET^XUA4A72(IEN,DATE)
  1. . . 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
  1. . . I DATE>0,ECUTN<1,'$D(^EC(722,"B",IEN)) Q ;134 Allows for users in file 722
  1. . . 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
  1. . . S I=I+1,^TMP($J,"ECFIND",I)=IEN_"^"_FROM_"^"_$P(ECUTN,"^",2,4)
  1. Q
  1. LEX ; returns a list of ICD code from lexicon lookup; called from ECUMRPC1
  1. ;Input Variables:-
  1. ; ECSTR - APP|ECX|ECDT
  1. ; application|Search string|procedure date
  1. ;
  1. ;Output Variables:-
  1. ; ^TMP($J,"ECFIND",1..n - returned array
  1. ; ICD Code^LEX description^IEN of file 80^IEN of file 757.01
  1. ;
  1. N LEX,ILST,I,IEN,ECX,APP,ECDT,ICD,ICDIEN,DIC,ECCS,ECCD,IMP
  1. S ECX=$P(ECSTR,"|",2),ECDT=$P(ECSTR,"|",3)
  1. S ECDT=$G(ECDT,DT),DIC="^ICD9("
  1. ; Determine Active Coding System based on Date Of Interest
  1. S ECCS=$$SINFO^ICDEX("DIAG",ECDT) ; Supported by ICR #5747
  1. ;spacebar default for DUZ
  1. I ECX=" ",+($G(DUZ))>0 S IEN=$G(^DISV(DUZ,DIC)) I +IEN D
  1. .; Load the ICD code info - Supported by ICR 5747
  1. .S ECCD=$$ICDDX^ICDEX(IEN,ECDT,+ECCS,"I") S:+ECCD>0 ECX=$P(ECCD,U,2)
  1. S IMP=$$IMPDATE^LEXU("10D"),APP=$S(ECDT<IMP:"ICD",1:"10D") ; Supported by ICR 5679
  1. K ^TMP("LEXSCH",$J)
  1. D CONFIG^LEXSET(APP,APP,ECDT) ;LEX DBIA1577
  1. D LOOK^LEXA(ECX,APP,1,"",ECDT) ;LEX DBIA2950
  1. I '$D(LEX("LIST",1)) S ^TMP($J,"ECFIND",1)="0^No matches found." Q
  1. ;LEX DBIA1573
  1. S ILST=1,IEN=+LEX("LIST",1)
  1. D ICD I ICDIEN<0 S ^TMP($J,"ECFIND",1)="0^No matches found." Q
  1. S ^TMP($J,"ECFIND",ILST)=ICD_U_$P(LEX("LIST",1),U,2)_U_ICDIEN_U_LEX("LIST",1),I=""
  1. ; ICD10 Changed to maximum of 101 entries
  1. F S I=$O(^TMP("LEXFND",$J,I)) Q:I'<0!(ILST=101) D
  1. .; Loop through all the ICD codes
  1. .S IEN=""
  1. .F S IEN=$O(^TMP("LEXFND",$J,I,IEN)) Q:'IEN D
  1. ..D ICD I ICDIEN<0 Q
  1. ..S ILST=ILST+1
  1. ..S ^TMP($J,"ECFIND",ILST)=ICD_U_^TMP("LEXFND",$J,I,IEN)_U_ICDIEN_U_IEN
  1. I $O(^TMP($J,"ECFIND",0))="" S ^TMP($J,"ECFIND",1)="0^No matches found."
  1. K ^TMP("LEXFND",$J),^TMP("LEXHIT",$J)
  1. Q
  1. ;
  1. ICD ;ICD code
  1. S ICD=$$ONE^LEXU(IEN,ECDT,APP) ; Supported by ICR 5679, ICD-9 and ICD-10
  1. S ECCS=$$SINFO^ICDEX("DIAG",ECDT) ; Supported by ICR #5747
  1. S ICDIEN=+$$ICDDX^ICDEX(ICD,ECDT,+ECCS,"E") ; Supported by ICR #5747
  1. Q
  1. ;
  1. DTPD(RESULTS,ECARY) ;Delete test patient data
  1. ;134 Section added for deleting test patient data
  1. ;Input Variable
  1. ; ECARY - Set to "I" to get information or "D" to delete records
  1. ;Output variable
  1. ; RESULT - Returns account info when ECARY is "I" or success
  1. ; when ECARY is "D"
  1. ;
  1. N MODE,ZTRTN,ZTIO,ZTDTH,ZTSK
  1. S MODE=$P(ECARY,U) Q:MODE=""
  1. D SETENV^ECUMRPC ;Set up minimal variables for an RPC call
  1. K ^TMP($J,"ECDELETE") ;Clear TMP global space
  1. I MODE="I" D S RESULTS=$NA(^TMP($J,"ECDELETE")) Q
  1. .S $P(^TMP($J,"ECDELETE",0),U)=$S($$PROD^XUPROD=0:"Test",1:"Production") ;Is account a test or production environment
  1. .S $P(^TMP($J,"ECDELETE",0),U,2)=$S($G(^XMB("NETNAME"))'="":$G(^XMB("NETNAME")),1:"network name undefined") ;Get account/network name
  1. .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
  1. .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
  1. .S $P(^TMP($J,"ECDELETE",0),U,5)=+$P($G(^XTMP("ECDELETE","DEL")),U,3) ;Status of deletion (0 not running, 1 if running)
  1. ;
  1. ;If deleting, queue to run in the background
  1. I MODE="D" D S RESULTS=$NA(^TMP($J,"ECDELETE")) Q
  1. .S ZTRTN="DEL^ECDTPD",ZTIO="",ZTDTH=$$NOW^XLFDT,ZTDESC="Delete test patient data from Event Capture Patient file (#721)"
  1. .D ^%ZTLOAD
  1. .S ^TMP($J,"ECDELETE",0)=$S($G(ZTSK):1,1:0) ;Return 1 if success, otherwise 0
  1. .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
  1. .Q
  1. Q
  1. ;
  1. 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
  1. ; RPC: EC DELETE ENTRY
  1. ;INPUTS ECARY - array with data to be deleted
  1. ; ECARY("ECFILE")=file #
  1. ; ECARY("IEN")=ien to be deleted from the file
  1. ;
  1. ;OUTPUTS RESULTS - Success or failure to file
  1. ;
  1. N ECFILE,ECDUZ
  1. D SETENV^ECUMRPC
  1. D PARSE^ECFLRPC
  1. K ^TMP($J,"ECMSG")
  1. I $G(ECFILE)="" S ^TMP($J,"ECMSG",1)="0^File Not defined" D END^ECFLRPC Q
  1. S:$G(DUZ) ECDUZ=DUZ
  1. I ECFILE=720.3 D DELECSR^ECMDECS,END^ECFLRPC Q
  1. I ECFILE=724 D DELDSS^ECMDDSSU,END^ECFLRPC Q
  1. S ^TMP($J,"ECMSG",1)="0^Deletion Not Available"
  1. D KILLVAR^ECFLRPC
  1. S RESULTS=$NA(^TMP($J,"ECMSG"))
  1. Q