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

ECUMRPC1.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. DSSUNT(RESULTS,ECARY) ;
  1. ;
  1. ;This broker entry point returns DSS units from file 724
  1. ; RPC: EC GETDSSUNIT
  1. ;INPUTS ECARY -Contains the following subscripted elements
  1. ; P1 = optional field to return DSS Units
  1. ; STAT; 'A'ctive (default), 'I'nactive, 'B'oth
  1. ; P2 = optional field to filter based on the DSS Name
  1. ; P3 = optional field to return 1 DSS unit by IEN, if used
  1. ; no other filters evaluated
  1. ; P4 = optional field to filter based on the DSS Unit Number (DSS Dept)
  1. ;
  1. ; if data is passed into the other fields then all criteria
  1. ; must be met for data on a unit to be returned
  1. ;
  1. ;OUTPUTS RESULTS - Array of DSS units. Data pieces as follows:-
  1. ; PIECE - Description
  1. ; 1 IEN of DSS Unit
  1. ; 2 Name of DSS Unit
  1. ; 3 IEN of DSS Unit
  1. ; 4 Inactive flag
  1. ; 5 Send to PCE
  1. ; 6 Unit Number
  1. ; 7 Service
  1. ; 8 Medical Specialty
  1. ; 9 Cost Center
  1. ; 10 Associated Stop code (if not sending to PCE)
  1. ; 11 Category flag
  1. ; 12 Default date entry
  1. ; 13 Credit Stop Code (only available when SEND TO PCE is set to "no records"
  1. ; 14 CHAR4 code (only available when SEND TO PCE is set to "no records"
  1. ; 15 Allow duplicate records in spreadsheet upload
  1. ;
  1. N UNT,STAT,CNT,CAT,NODE,ECS,STR,SRV,MED,CST,UNO,INACT,ASC,PCE,ACT,NODE
  1. N DFD,DIEN,DNM,DUNIT,GET1,CSC,CHAR4,ADSS ;126,139
  1. D SETENV^ECUMRPC
  1. K ^TMP($J,"ECDSSUNT")
  1. S DNM=$P($G(ECARY),U,2),DIEN=$P($G(ECARY),U,3),DUNIT=$P($G(ECARY),U,4)
  1. S:DNM'="" DNM=$$UP^XLFSTR(DNM)
  1. S:DUNIT'="" DUNIT=$$UP^XLFSTR(DUNIT)
  1. S STAT=$P($G(ECARY),U),(CNT,UNT,GET1)=0 S:STAT="" STAT="A"
  1. ; if IEN passed in - use that, then quit, GET1 used as control to stop
  1. I $G(DIEN) S UNT=DIEN-.001,GET1=1
  1. F S UNT=$O(^ECD(UNT)) Q:'UNT!((UNT>DIEN&(GET1))) S NODE=$G(^ECD(UNT,0)) I NODE'="" D
  1. . S ECS=$P(NODE,U,8),ACT=$P(NODE,U,6),ACT=$S(ACT:1,1:0)
  1. . Q:('ECS)
  1. . I '$G(DIEN),$S(STAT="A"&(ACT):1,STAT="I"&('ACT):1,1:0) Q
  1. . ; execute new filters
  1. . I DNM'="",$$UP^XLFSTR($P(NODE,U))'[DNM Q
  1. . I DUNIT'="",$$UP^XLFSTR($P(NODE,U,5))'[DUNIT Q
  1. . I DIEN'="",$$UP^XLFSTR(UNT)'[DIEN Q
  1. . S CNT=CNT+1,CAT=$P(NODE,U,11),CAT=$S(CAT:"Y",1:"N"),UNO=$P(NODE,U,5)
  1. . S SRV=$$GET1^DIQ(49,$P(NODE,U,2),.01,"I")
  1. . S MED=$$GET1^DIQ(723,$P(NODE,U,3),.01,"I")
  1. . S CST=$$GET1^DIQ(420.1,$P(NODE,U,4),.01,"I")
  1. . 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
  1. . S:ASC ASC=$$GET1^DIQ(40.7,ASC,.01,"I")
  1. . S:CSC CSC=$$GET1^DIQ(40.7,CSC,.01) ;126
  1. . S:CHAR4 CHAR4=$$GET1^DIQ(728.441,CHAR4,.01) ;126
  1. . S DFD=$S($P(NODE,U,12)="N":"N",1:"X"),PCE=$P(NODE,U,14)
  1. . S PCE=$S(PCE'="":PCE,1:"N") ;139
  1. . S ADSS=$S($P(NODE,U,16)'="":$P(NODE,U,16),1:"N") ;139 Does DSS Unit allow duplicate record upload
  1. . S STR=UNT_U_$P(NODE,U)_U_UNT_U_INACT_U_PCE_U_UNO_U_SRV_U_MED_U_CST
  1. . S STR=STR_U_ASC_U_CAT_U_DFD_U_CSC_U_CHAR4_U_ADSS,^TMP($J,"ECDSSUNT",CNT)=STR ;126,139
  1. S RESULTS=$NA(^TMP($J,"ECDSSUNT"))
  1. Q
  1. CAT(RESULTS,ECARY) ;
  1. ;
  1. ;This broker entry point returns a list of categories from file 726
  1. ; RPC: EC GETCAT
  1. ;INPUTS ECARY - Contains the following subscripted elements
  1. ; STAT - Active or inactive category (optional)
  1. ; A-ctive (default), I-nactive, B-oth
  1. ;
  1. ;OUTPUTS RESULTS - Array of category. Data pieces as follows:-
  1. ; PIECE - Description
  1. ; 1 IEN of Category
  1. ; 2 Name of Category
  1. ; 3 Creation Date
  1. ; 4 Inactive Date
  1. ;
  1. N STAT,CNT,CAT,NODE,ECDT,INDT,CRDT
  1. D SETENV^ECUMRPC
  1. K ^TMP($J,"ECCAT")
  1. S STAT=$P($G(ECARY),U),(CNT,CAT)=0 S:STAT="" STAT="A"
  1. F S CAT=$O(^EC(726,CAT)) Q:'CAT S NODE=$G(^EC(726,CAT,0)) I NODE'="" D
  1. . S ECDT=$P(NODE,U,3)
  1. . I STAT="A",ECDT'="",ECDT'>DT Q
  1. . I STAT="I",ECDT="" Q
  1. . S CRDT=$$FMTE^XLFDT($P(NODE,U,2),"2F")
  1. . S INDT=$$FMTE^XLFDT($P(NODE,U,3),"2F")
  1. . ;S CNT=CNT+1,^TMP($J,"ECCAT",CNT)=CAT_U_$P(NODE,U)_U_CRDT_U_INDT
  1. . S CNT=CNT+1,^TMP($J,"ECCAT",CNT)=CAT_U_$P(NODE,U)_U_$P(CRDT,"@",1)_U_$P(INDT,"@",1)
  1. S RESULTS=$NA(^TMP($J,"ECCAT"))
  1. Q
  1. ;
  1. CATCHK(RESULTS,ECARY) ;
  1. ;
  1. ;Broker call checks whether category is used in an Event Code Screen.
  1. ; RPC: EC DSSCATCHECK
  1. ;INPUTS ECARY - Contains the following subscripted elements
  1. ; ECDA - DSS Unit ien (file #724)
  1. ;
  1. ;OUTPUTS RESULTS - Category used in Event Code Screen, 1-Yes or 0-No
  1. ;
  1. N ECDA,ECFLG,ECX
  1. D SETENV^ECUMRPC
  1. S ECDA=$P(ECARY,U) I ECDA="" Q
  1. S (ECFLG,ECX)=0
  1. F S ECX=$O(^ECJ("AP",ECX)) Q:'ECX!(ECFLG) D
  1. . I $D(^ECJ("AP",ECX,ECDA)) S ECFLG=1
  1. S RESULTS=ECFLG
  1. Q
  1. PXCHK(RESULTS,ECARY) ;
  1. ;
  1. ;Checks whether procedure description or national number exist
  1. ;INPUTS ECARY - Contains the following subscripted elements
  1. ; ECP - Procedure description
  1. ; ECN - EC National Number
  1. ;
  1. ;OUTPUTS RESULTS - Px used^National # used, 1-Yes or 0-No ex. 1^0
  1. ;
  1. N ECX,ECP,ECN
  1. Q:$G(ECARY)
  1. D SETENV^ECUMRPC
  1. S ECP=$P(ECARY,U),ECN=$P(ECARY,U,2),RESULTS="0^0"
  1. I ECP'="",$D(^EC(725,"B",ECP)) S $P(RESULTS,U)=1
  1. I ECN'="" F ECX="E","D","DL" D I $P(RESULTS,U,2) Q
  1. . I $D(^EC(725,ECX,ECN)) S $P(RESULTS,U,2)=1
  1. Q
  1. SRCLST(RESULTS,ECARY) ;
  1. ;
  1. ;This broker entry returns an array of codes from a file based on a
  1. ;search string.
  1. ; RPC: EC GETLIST
  1. ;
  1. ;INPUTS ECARY - Contains the following subscripted elements
  1. ; ECFIL - File to search
  1. ; ECSTR - Search string
  1. ; ECDIR - Search order
  1. ; ECNUM - (Optional) # records to return [default=44]
  1. ; ECADT - (Optional) date to determine clinic inactivity
  1. ; ECLOC - (Optional) location to filter associated clinics
  1. ; ECTYPE - (Optional) primary or secondary stop codes desired
  1. ; ECOOS - (Optional) Set to "OOS" to only see "OOS" related stop codes
  1. ;OUTPUTS RESULTS - Array of values based on the search criteria.
  1. ;
  1. N ECNT,DIC,ECSTR,ECFIL,ECORD,ECER,ECDI,ECNUM,ECDIR,ECADT,ECLOC,ECTYPE,ECOOS ;112,126,139
  1. D SETENV^ECUMRPC
  1. S ECNT=0,ECFIL=$P(ECARY,U),ECSTR=$P(ECARY,U,2),ECDIR=$P(ECARY,U,3)
  1. S ECORD=$S(ECDIR=-1:"B",1:"I")
  1. K ^TMP($J,"ECFIND"),^TMP("ECSRCH",$J)
  1. I ECFIL="" Q
  1. S ECNUM=$S(+$P(ECARY,U,4)>0:$P(ECARY,U,4),1:44)
  1. S ECADT=$S(+$P(ECARY,U,5):$P(ECARY,U,5),1:DT) ;112
  1. S ECLOC=$P(ECARY,U,6) ;126 IEN of location if filtering. Null if no filtering
  1. S ECTYPE=$P(ECARY,U,7) ;126 Null if primary, not null for secondary
  1. S ECOOS=$P(ECARY,U,8) ;139 Set to "OOS" if list is restricted to "OOS" type stop codes
  1. I ECFIL=420.1 D CSTCTR ;Cost Center search
  1. I ECFIL=49 D SERVC ;Service search
  1. I ECFIL=723 D MEDSPC ;Medical specialty
  1. I ECFIL=40.7 D STPCDE G EXIT ;Associated stop code
  1. I ECFIL=724 D DUNT G EXIT ;DSS Unit
  1. I ECFIL=726 D ECAT ;Category
  1. I ECFIL=4 D LOC ;Location
  1. I ECFIL=44 D ASCLN G EXIT ;Associated clinic
  1. I ECFIL=757.01 D LEX^ECUMRPC2 G EXIT ;Lex ICD code
  1. I ECFIL=200 D PROV^ECUMRPC2(ECNUM) ;Providers
  1. I ECFIL=728.441 D CHAR4 ;126 National Clinic code (CHAR4)
  1. I ECFIL=722 D LIST^ECPRVDR ;134 EC Providers
  1. I $D(ECER) S ^TMP($J,"ECFIND",1)="0^Error occurred during search" G EXIT
  1. D SORT
  1. EXIT K ^TMP("ECSRCH",$J)
  1. S RESULTS=$NA(^TMP($J,"ECFIND"))
  1. Q
  1. ASCLN ;Search for active associated clinics (file #44)
  1. N CLN,CNT,NOD,ECDT,INACT,REACT,ERR,ECNOD ;126
  1. N ECRES,ECAC ;152
  1. S CNT=0,ECDT=ECADT ;112
  1. I (ECDIR'=1)&(ECDIR'=-1) S ECDIR=1
  1. ;the next 2 lines of code compensate for the M collating sequence & how the
  1. ;clinic code is passed in from a CPRS RPC, in a unique situation. If the
  1. ;code is numeric, ending in 0 and there is a similar code ending with a
  1. ;letter, the correct clinic is not returned. EX: 2 clinics, 3010 and "3010A"
  1. ;exist, the code is written to return 3010, yet 3010A is incorrectly returned.
  1. ;This code puts the 0 back on and subtracts 1 to the clinic code
  1. I $E(ECSTR,$L(ECSTR)-1)="/",$E(ECSTR,1,($L(ECSTR)-2))?.N D
  1. .S ECSTR=$E(ECSTR,1,($L(ECSTR)-2))_0,ECSTR=ECSTR-1
  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
  1. .F S CLN=$O(^SC("B",ECSTR,CLN),ECDIR) Q:CLN="" S NOD=$G(^SC(CLN,0)) D
  1. ..Q:NOD="" Q:$P(NOD,U,3)'="C" ;Q:+$G(^SC(CLN,"OOS"))
  1. ..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
  1. ..S ERR=0 I $D(^SC(CLN,"I")) D I ERR Q
  1. ...S INACT=$P(^SC(CLN,"I"),U),REACT=$P(^SC(CLN,"I"),U,2)
  1. ...I INACT D I ERR Q
  1. ....I REACT="" S:ECDT'<INACT ERR=1 Q
  1. ....I ECDT'<INACT,ECDT<REACT S ERR=1 Q
  1. ...;I REACT,ECDT<REACT S ERR=1 removed in EC*110 - BGP
  1. ..S ECNOD=$G(^ECX(728.44,CLN,0)) ;126 Get clinic and stop code zero node for selected clinic
  1. ..;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
  1. ..I $P(ECNOD,U,2)'="" D ;152 Only valid clinics are added to the list
  1. ...S ECRES=$$CLNCK^SDUTL2(CLN,0) I 'ECRES Q ;
  1. ...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
  1. Q
  1. CSTCTR ;Search for cost centers (File #420.1)
  1. N ECNULL,INDX,STR,NSTR,I
  1. S $P(ECNULL," ",7)=" ",INDX="B"
  1. I $E(ECSTR)?.N,$L(ECSTR)<7 S ECSTR=ECSTR_$E(ECNULL,1,7-$L(ECSTR))
  1. I $L($P(ECSTR," "))=6,$P(ECSTR," ",2)?.A D ;truncate for x-ref
  1. . S ECSTR=$P(ECSTR," ")_" "_$E($P(ECSTR," ",2,999),1,22)
  1. I $E(ECSTR)?.A S INDX="C",(STR,NSTR)="" D S ECSTR=NSTR
  1. .F I=1:1 S STR=$P(ECSTR," ",I) Q:STR="" D
  1. ..S STR=$E(STR)_$TR($E(STR,2,9999),"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
  1. ..S NSTR=NSTR_STR
  1. D LISTDIC(ECFIL,"",.01,ECORD,ECNUM,ECSTR,"",INDX,"I '$P(^(0),U,2)","","^TMP(""ECSRCH"",$J)","ECER")
  1. Q
  1. SERVC ;Search for services (File #49)
  1. D LISTDIC(ECFIL,"",.01,ECORD,ECNUM,ECSTR,"","","","","^TMP(""ECSRCH"",$J)","ECER")
  1. Q
  1. MEDSPC ;Search for medical specialty (File #723)
  1. D LISTDIC(ECFIL,"",.01,ECORD,ECNUM,ECSTR,"","","","","^TMP(""ECSRCH"",$J)","ECER")
  1. Q
  1. STPCDE ;Search for associated stop code (File #40.7)
  1. N ECNT,INDX,ECNUL,STR,IEN,SCRN ;139
  1. S $P(ECNUL," ",30)=" ",INDX="B",ECNT=0,ECSTR=$P(ECSTR,"~")
  1. I +ECSTR,ECSTR["/" S ECSTR=$TR(ECSTR,"/",0) S:ECSTR>0 ECSTR=ECSTR-1 ;131 If number sent, remove / and replace with 0
  1. I +ECSTR,+ECSTR?.N S INDX="C",IEN=0 D Q
  1. .S ECSTR=$O(^DIC(40.7,INDX,+ECSTR)) I ECSTR="" Q
  1. .F S IEN=$O(^DIC(40.7,INDX,ECSTR,IEN)) Q:'IEN D I ECNT>(ECNUM-1) Q
  1. ..;07/27/09 llh added checks on piece 2 and 6
  1. ..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
  1. ..I $G(ECOOS)="OOS" I '$$EX^SDCOU2(IEN,$$NOW^XLFDT) Q ;139 If setting up OOS DSS unit, only show OOS related stop codes
  1. ..S STR=$E($P(STR,U),1,30)_" ["_$J($P(STR,U,2),3,0)_"]"_U_$P(STR,U,2)_U_IEN
  1. ..S ECNT=ECNT+1,^TMP($J,"ECFIND",ECNT)=STR
  1. ;added validation checks here as well
  1. 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
  1. D LISTDIC(ECFIL,"",".01;1",ECORD,ECNUM,ECSTR,"",INDX,SCRN,"","^TMP(""ECSRCH"",$J)","ECER") ;126,139
  1. S ECNT=0
  1. F S ECNT=$O(^TMP("ECSRCH",$J,"DILIST","ID",ECNT)) Q:'ECNT D
  1. .S STR=$G(^TMP("ECSRCH",$J,"DILIST","ID",ECNT,.01))_U_$G(^(1))
  1. .S STR=$E($P(STR,U),1,30)_" ["_$J($P(STR,U,2),3,0)_"]"_U_$P(STR,U,2)
  1. .S ^TMP($J,"ECFIND",ECNT)=STR_U_^TMP("ECSRCH",$J,"DILIST",2,ECNT)
  1. Q
  1. DUNT ;Search for DSS unit (File #724)
  1. N ECNT,SNDPCE
  1. D LISTDIC(ECFIL,"",".01;10;13",ECORD,ECNUM,ECSTR,"","","I '$P(^(0),""^"",6),$P(^(0),U,8)","","^TMP(""ECSRCH"",$J)","ECER")
  1. S ECNT=0
  1. F S ECNT=$O(^TMP("ECSRCH",$J,"DILIST","ID",ECNT)) Q:'ECNT D
  1. .S SNDPCE=$G(^TMP("ECSRCH",$J,"DILIST","ID",ECNT,13))
  1. .S SNDPCE=$S(SNDPCE="A":1,1:0) ;139 Send all records enables clinic selection, else no clinic
  1. .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
  1. Q
  1. ECAT ;Search for Category (File #726)
  1. D LISTDIC(ECFIL,"",.01,ECORD,ECNUM,ECSTR,"","","I $P(^(0),""^"",3)=""""!($P(^(0),U,3)>DT)","","^TMP(""ECSRCH"",$J)","ECER")
  1. Q
  1. LOC ;Search for Location (File #4)
  1. D LISTDIC(ECFIL,"",.01,ECORD,ECNUM,ECSTR,"","","I $G(^(""EC""))","","^TMP(""ECSRCH"",$J)","ECER")
  1. Q
  1. 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
  1. N DIC
  1. D LIST^DIC(ECFL,ECIEN,ECFLD,ECFLG,ECNUM,ECFRM,ECPRT,ECINDX,ECSCN,ECIND,ECTG,ECER)
  1. K ECFL,ECIEN,ECFLD,ECFLG,ECNUM,ECFRM,ECPRT,ECINDX,ECSCN,ECID
  1. Q
  1. SORT ;Extracts data to be returned to broker
  1. N ECNT,STR
  1. S ECNT=0
  1. F S ECNT=$O(^TMP("ECSRCH",$J,"DILIST","ID",ECNT)) Q:'ECNT D
  1. .S ^TMP($J,"ECFIND",ECNT)=$G(^TMP("ECSRCH",$J,"DILIST","ID",ECNT,.01))_U_^TMP("ECSRCH",$J,"DILIST",2,ECNT)
  1. Q
  1. ;
  1. CHAR4 ;126, returns list of CHAR4 codes from the NATIONAL CLINIC file (#728.441)
  1. D LISTDIC(ECFIL,"",.01,ECORD,ECNUM,ECSTR,"","","I $P($G(^(2)),""^"")=""""!($P($G(^(2)),""^"")>DT)","","^TMP(""ECSRCH"",$J)","ECER")