iSharkFly-Open
/
VistA-WorldVistAEHR
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
VistA-WorldVistAEHR/r/CLINICAL_CASE_REGISTRIES-ROR/RORUTL02.m

266 lines
8.3 KiB
Mathematica
Raw Blame History

RORUTL02 ;HCIOFO/SG - UTILITIES ; 8/25/05 10:20am
;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
;
; This routine uses the following IAs:
;
; #2701 $$GETICN^MPIF001 Gets ICN (supported)
; #3556 $$GCPR^LA7QRY
; #3557 Access to the field .01 and x-ref "B"
; of the file 95.3
; #3646 $$EMPL^DGSEC4
; #10035 Access to the field #.09 of the file #2
;
Q
;
;***** REMOVES THE INACTIVE REGISTRIES FROM THE LIST
;
; .REGLST( A list of registry names (as subscripts)
; RegName) Registry IEN (output)
;
; Return values:
; <0 Error code
; 0 Ok
;
; This function removes names of those registries that are
; inactive or cannot be updated for any other reasons from
; the list. It also associates registry IENs with the names
; of registries remaining on the list.
;
; Moreover, it records corresponding messages about skipped
; registries to the current open log.
;
ARLST(REGLST) ;
N INFO,RC,REGIEN,REGNAME,RORBUF,TMP K DSTLST
S REGNAME="",RC=0
F S REGNAME=$O(REGLST(REGNAME)) Q:REGNAME="" D Q:RC<0
. S REGIEN=$$REGIEN(REGNAME,"@;11I;21.05I",.RORBUF)
. ;--- Cannot find (or load) the registry parameters
. I REGIEN'>0 D Q
. . D ERROR^RORERR(REGIEN,,REGNAME)
. . K REGLST(REGNAME)
. ;--- Check if the registry is marked as 'inactive'
. I $G(RORBUF("DILIST","ID",1,11)) D Q
. . D ERROR^RORERR(-48,,,,REGNAME)
. . K REGLST(REGNAME)
. ;--- Check if the registry has not been populated
. I '$G(RORBUF("DILIST","ID",1,21.05)),'$G(RORPARM("SETUP")) D Q
. . D TEXT^RORTXT(7980000.02,.INFO)
. . D ERROR^RORERR(-103,,.INFO,,REGNAME)
. . K INFO,REGLST(REGNAME)
. ;--- Store the registry IEN
. S REGLST(REGNAME)=REGIEN
Q RC
;
;***** RETURNS A FULL ICN OF THE PATIENT
;
; PTIEN Patient IEN
;
; Return Values:
; <0 Error code
; "" ICN has not been assigned
; >0 Patient ICN
;
ICN(PTIEN) ;
N ICN,L,TMP
S ICN=$$GETICN^MPIF001(PTIEN)
I ICN'>0 D Q ""
. S TMP=$$ERROR^RORERR(-57,,$P(ICN,U,2),PTIEN,+ICN,"$$GETICN^MPIF001")
;--- Validate the checksum (just in case ;-)
S L=$L($P(ICN,"V",2))
Q $S(L<6:$P(ICN,"V")_"V"_$E("000000",1,6-L)_$P(ICN,"V",2),1:ICN)
;
;***** LOADS THE LAB RESULTS
;
; PTIEN Patient IEN
;
; SDT Start date of the results
; EDT End date of the results
;
; [ROR8DST] Closed root of the destination array
; (the ^TMP("RORTMP",$J) node, by default)
;
; Return values:
; <0 Error code
; 0 Ok
;
LABRSLTS(PTIEN,SDT,EDT,ROR8DST) ;
N H7CH,RC,RORMSG,TMP
S:$G(ROR8DST)="" ROR8DST=$NA(^TMP("RORTMP",$J))
K @ROR8DST
I $D(RORLRC)<10 Q:$G(RORLRC)="" 0
;--- Get the Patient ID (ICN or SSN)
S PTID=$$PTID(PTIEN) Q:PTID<0 PTID
;--- Get the Lab data
S H7CH=$G(RORHL("FS"))_$G(RORHL("ECH"))
S RC=$$GCPR^LA7QRY(PTID,SDT,EDT,.RORLRC,"*",.RORMSG,ROR8DST,H7CH)
I RC="",$D(RORMSG)>1 D
. N ERR,I,LST
. S (ERR,LST)=""
. F I=1:1 S ERR=$O(RORMSG(ERR)) Q:ERR="" D
. . S LST=LST_","_ERR,TMP=RORMSG(ERR)
. . K RORMSG(ERR) S RORMSG(I)=TMP
. S LST=$P(LST,",",2,999) Q:(LST=3)!(LST=99)
. S RC=$$ERROR^RORERR(-27,,.RORMSG,PTIEN)
Q $S(RC<0:RC,1:0)
;
;***** RETURNS THE LOINC CODE WITH THE CONTROL DIGIT
;
; LNCODE LOINC code
;
; Besides adding a control digit to the LOINC code, the function
; checks the code against the LAB LOINC file (#95.3).
;
; Return values:
; <0 Error code
; >0 LOINC code with the control digit
;
LNCODE(LNCODE) ;
N RC,RORBUF,RORMSG
D FIND^DIC(95.3,,"@;.01E","X",$P(LNCODE,"-"),2,"B",,,"RORBUF","RORMSG")
Q:$G(DIERR) $$DBS^RORERR("RORMSG",-9,,,95.3)
I $G(RORBUF("DILIST",0))<1 D Q RC ; Non-existent code
. S RC=$$ERROR^RORERR(-29,,,,LNCODE)
I $G(RORBUF("DILIST",0))>1 D Q RC ; Duplicate records
. S RC=$$ERROR^RORERR(-30,,,,LNCODE)
Q RORBUF("DILIST","ID",1,.01)
;
;***** LOCK/UNLOCK REGISTRIES BEING PROCESSED
;
; .REGLST Reference to a local array containing registry names
; as subscripts and optional registry IENs as values
; [MODE] 0 - Unlock (default), 1 - Lock
; [TO] LOCK timeout (3 sec by defualt)
; [NAME] Name of the process/task
;
; Return Values:
; <0 Error code
; 0 Some of the registries has been locked by another job
; 1 Ok
;
LOCKREG(REGLST,MODE,TO,NAME) ;
Q:$D(REGLST)<10 1
N LOCKLST,RC,REGIEN,REGNAME
S REGNAME=""
F S REGNAME=$O(REGLST(REGNAME)) Q:REGNAME="" D Q:REGIEN<0
. S REGIEN=+$G(REGLST(REGNAME))
. I REGIEN'>0 S REGIEN=$$REGIEN^RORUTL02(REGNAME) Q:REGIEN'>0
. S LOCKLST(798.1,REGIEN_",")=""
Q:$G(REGIEN)<0 REGIEN
Q:$D(LOCKLST)<10 1
I $G(MODE) D
. S RC=$$LOCK^RORLOCK(.LOCKLST,,,+$G(TO,3),$G(NAME))
E S RC=$$UNLOCK^RORLOCK(.LOCKLST)
Q $S('RC:1,RC<0:RC,1:0)
;
;***** RETURNS A PATIENT ID (ICN OR SSN)
;
; PTIEN Patient IEN
;
; Return Values:
; <0 Error code
; "" Neither ICN nor SSN has been assigned
; >0 Patient ICN (or SSN if ICN is not available)
;
PTID(PTIEN) ;
N L,PTID,RC,RORMSG
S PTID=$$GETICN^MPIF001(PTIEN)
I PTID>0 D Q PTID
. ;--- Validate the checksum (just in case ;-)
. S L=$L($P(PTID,"V",2)) Q:L'<6
. ;S RC=$$ERROR^RORERR(-59,,,PTIEN)
. S $P(PTID,"V",2)=$E("000000",1,6-L)_$P(PTID,"V",2)
;--- Get SSN if ICN is not available
S PTID=$$GET1^DIQ(2,PTIEN_",",.09,,,"RORMSG")
Q:$G(DIERR) $$DBS^RORERR("RORMSG",-9,,PTIEN,2)
Q PTID
;
;***** RETURNS IEN OF THE REGISTRY PARAMETERS
;
; REGNAME Name of the registry
; [FIELDS] List of fields (separated by semicolons) to load
; [.RORTRGT] Reference to a local variable where field values will
; be stored by the FIND^DIC call
;
; Return Values:
; <0 Error code
; >0 Registry parameters IEN
;
REGIEN(REGNAME,FIELDS,RORTRGT) ;
N RC,REGIEN,RORMSG K RORTRGT
D FIND^DIC(798.1,,"@;"_$G(FIELDS),"UX",REGNAME,2,"B",,,"RORTRGT","RORMSG")
Q:$G(DIERR) $$DBS^RORERR("RORMSG",-9,,,798.1)
S RC=+$G(RORTRGT("DILIST",0))
Q $S(RC<1:-1,RC>1:-2,1:+RORTRGT("DILIST",2,1))
;
;***** RETURNS NUMBER OF RECORDS IN THE REGISTRY
;
; REGIEN Registry IEN
; [.LOWIEN] The smallest IEN will be returned via this parameter
; [.HIGHIEN] The biggest IEN will be returned via this parameter
;
; Return Values:
; <0 Error code
; 0 The registry is empty
; >0 Number of records in the registry
;
REGSIZE(REGIEN,LOWIEN,HIGHIEN) ;
N I,NODE,NRE,RC,RORFDA,RORMSG
S NODE=$NA(^RORDATA(798,"AC",REGIEN))
S LOWIEN=$O(@NODE@(""))
S HIGHIEN=$O(@NODE@(""),-1)
;--- Get number of records from the parameters
S NRE=$$GET1^DIQ(798.1,REGIEN_",",19.1,,,"RORMSG")
Q:$G(DIERR) $$DBS^RORERR("RORMSG",-9,,,798.1,REGIEN)
Q:NRE>0 NRE
;--- Count the records of the registry
S I="",NRE=0
F S I=$O(@NODE@(I)) Q:I="" S NRE=NRE+1
;--- Store the value in the parameters
S RORFDA(798.1,REGIEN_",",19.1)=NRE
D FILE^DIE("K","RORFDA","RORMSG")
Q NRE
;
;***** CHECKS IF AN EMPLOYEE SHOULD BE SKIPPED
;
; PTIEN Patient IEN
;
; [.]REGIEN Registry IEN
;
; If you are going to call this function for several
; patients in a row (in a cycle), you can pass the
; second parameter by reference. This will eliminate
; repetitive access to the registry parameters (the
; REGIEN("SE") node will be used as a "cache" for the
; value of the EXCLUDE EMPLOYEES field).
;
; Return Values:
; 0 Patient can be added to the registry
; 1 Patient should be skipped
;
; The function checks if the patient is an employee and if he/she
; can be added to the registry (according to the value of the
; EXCLUDE EMPLOYEES field of the ROR REGISTRY PARAMETERS file).
;
SKIPEMPL(PTIEN,REGIEN) ;
Q:'$$EMPL^DGSEC4(PTIEN,"P") 0
S:'$D(REGIEN("SE")) REGIEN("SE")=+$P($G(^ROR(798.1,+REGIEN,0)),U,10)
Q +REGIEN("SE")
;
;***** RETURNS IEN OF THE SELECTION RULE
;
; RULENAME Name of the selection rule
; [FIELDS] List of fields (separated by semicolons) to load
; [.RORTRGT] Reference to a local variable where field values will
; be stored by the FIND^DIC call.
;
; Return Values:
; <0 Error code
; >0 Selection rule IEN
;
SRLIEN(RULENAME,FIELDS,RORTRGT) ;
N RC,RULEIEN,RORMSG K RORTRGT
D FIND^DIC(798.2,,"@;"_$G(FIELDS),"X",RULENAME,2,"B",,,"RORTRGT","RORMSG")
Q:$G(DIERR) $$DBS^RORERR("RORMSG",-9,,,798.2)
S RC=+$G(RORTRGT("DILIST",0))
Q $S(RC<1:-3,RC>1:-4,1:+RORTRGT("DILIST",2,1))
Reference in New Issue View Git Blame Copy Permalink