RORUTL02 ;HCIOFO/SG - UTILITIES ;8/25/05 10:20am
;;1.5;CLINICAL CASE REGISTRIES;**21,27,31,33,34**;Feb 17, 2006;Build 45
;
;******************************************************************************
;******************************************************************************
; --- ROUTINE MODIFICATION LOG ---
;
;PKG/PATCH DATE DEVELOPER MODIFICATION
;----------- ---------- ----------- ----------------------------------------
;ROR*1.5*27 FEB 2015 T KOPP Changed LOCKREG entry point to loop thru
; registries to lock only 15 at a time to
; prevent maxstring errors when lock
; command is executed.
;ROR*1.5*31 MAY 2017 M FERRARESE Adding PACT and PCP as additional identifiers.
;ROR*1.5*33 MAY 2017 F TRAXLER Added FUTAPPT subroutine.
;ROR*1.5*34 SEP 2018 F TRAXLER Modified FUTAPPT subroutine.
;******************************************************************************
;
; This routine uses the following IAs:
;
; #2701 $$GETICN^MPIF001 Gets ICN (supported)
; $$IFLOCAL^MPIF001 (checks for local 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 NATIONAL ICN OF THE PATIENT
;
; PTIEN Patient IEN
;
; Return Values:
; <0 Error code
; "" ICN has not been assigned or ICN is a local ICN
; >0 Patient National ICN
;
ICN(PTIEN) ;
N ICN,L,TMP
I $$IFLOCAL^MPIF001(PTIEN) Q ""
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)
;
PACT(DFN) ;returns ien & name of pc team PATCH 30
; DFN - pointer to patient file
; Date of interest (Default=DT)
;
Q $P($$OUTPTTM^SDUTL3(DFN,DT),U,2)
;
PCP(DFN) ;returns ien & name of pract filling pc position PATCH 30
; DFN - pointer to patient file
; DATE - date of interest
; PCROLE - Practitioner Position where '1' = PC provider ; '2' = PC attending
; '3' = PC associate provider
;
; returns (ien^name), or "" if none or -1 if error
;
;
Q $P($$OUTPTPR^SDUTL3(DFN,DT,1),"^",2)
;
FUTAPPT(DFN,DAYS) ; PATCH 33
N RORAPPTDT,RORAPPTCNE,VASD
I $D(DAYS) D
.N X,X1,X2
.D NOW^%DTC S (VASD("F"),X1)=X,X2=DAYS D C^%DTC S VASD("T")=X
.S VASD("W")="1"
.D SDA^VADPT
I $D(^UTILITY("VASD",$J)) D Q RORAPPTDT_U_RORAPPTCNE ;patch 34 change
.S RORAPPTDT=$$DATE^RORXU002($P($G(^UTILITY("VASD",$J,1,"I")),U,1)\1) ;appt d/t
.S RORAPPTCNE=$P($G(^UTILITY("VASD",$J,1,"E")),U,2) ;appt clinic name (external)
;I $D(^UTILITY("VASD",$J)) Q $$DATE^RORXU002($P($G(^UTILITY("VASD",$J,1,"I")),"^",1)\1) ;patch 33 code
Q 0
;***** 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,RORLIST,RC,REGIEN,REGNAME
N CT,FAILS,Q,Q0,Z
; RORLIST = 0 if less than 15 entries to lock
; = 1 if 15 or more entries to lock
; (n,x,y) = the array in LOCKLST(x,y) at that point
; (where n = the # identifying the set of 15
; registries being locked at one time)
; FAILS = <0 or 1 ... lock failed = 0 ... lock was successful
S REGNAME="",CT=0,RORLIST=0
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 CT=CT+1
. S LOCKLST(798.1,REGIEN_",")=""
. I '(CT#15) D ; Split the locks into smaller chunks every 15 entries
.. M RORLIST(CT/15)=LOCKLST S RORLIST=1
.. K LOCKLST
Q:$G(REGIEN)<0 REGIEN
I RORLIST,$O(LOCKLST(""))'="" M RORLIST((CT/15\1)+1)=LOCKLST K LOCKLST
Q:$D(LOCKLST)<10&'$O(RORLIST(0)) 1
I $G(MODE) S RC=0 D
. I 'RORLIST S RC=$$LOCK^RORLOCK(.LOCKLST,,,+$G(TO,3),$G(NAME)) Q
. F Q=1:1 Q:'$D(RORLIST(Q))!RC D
.. K LOCKLST M LOCKLST=RORLIST(Q)
.. S FAILS=$$LOCK^RORLOCK(.LOCKLST,,,+$G(TO,3),$G(NAME)),RC=FAILS
.. ; If lock fails for at least one set of nodes [=1 or <0] - unlock previous locks
.. I FAILS D:Q>1
... F Q0=1:1:Q-1 K LOCKLST M LOCKLST=RORLIST(Q0) S Z=$$UNLOCK^RORLOCK(.LOCKLST)
E D
. I 'RORLIST S RC=$$UNLOCK^RORLOCK(.LOCKLST) Q
. S RC=0
. F Q=1:1 K LOCKLST Q:'$D(RORLIST(Q)) D
.. M LOCKLST=RORLIST(Q) S FAILS=$$UNLOCK^RORLOCK(.LOCKLST)
.. S:FAILS RC=FAILS
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))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORUTL02 12223 printed Sep 23, 2025@19:19:55 Page 2
RORUTL02 ;HCIOFO/SG - UTILITIES ;8/25/05 10:20am
+1 ;;1.5;CLINICAL CASE REGISTRIES;**21,27,31,33,34**;Feb 17, 2006;Build 45
+2 ;
+3 ;******************************************************************************
+4 ;******************************************************************************
+5 ; --- ROUTINE MODIFICATION LOG ---
+6 ;
+7 ;PKG/PATCH DATE DEVELOPER MODIFICATION
+8 ;----------- ---------- ----------- ----------------------------------------
+9 ;ROR*1.5*27 FEB 2015 T KOPP Changed LOCKREG entry point to loop thru
+10 ; registries to lock only 15 at a time to
+11 ; prevent maxstring errors when lock
+12 ; command is executed.
+13 ;ROR*1.5*31 MAY 2017 M FERRARESE Adding PACT and PCP as additional identifiers.
+14 ;ROR*1.5*33 MAY 2017 F TRAXLER Added FUTAPPT subroutine.
+15 ;ROR*1.5*34 SEP 2018 F TRAXLER Modified FUTAPPT subroutine.
+16 ;******************************************************************************
+17 ;
+18 ; This routine uses the following IAs:
+19 ;
+20 ; #2701 $$GETICN^MPIF001 Gets ICN (supported)
+21 ; $$IFLOCAL^MPIF001 (checks for local ICN) (supported)
+22 ; #3556 $$GCPR^LA7QRY
+23 ; #3557 Access to the field .01 and x-ref "B"
+24 ; of the file 95.3
+25 ; #3646 $$EMPL^DGSEC4
+26 ; #10035 Access to the field #.09 of the file #2
+27 ;
+28 QUIT
+29 ;
+30 ;***** REMOVES THE INACTIVE REGISTRIES FROM THE LIST
+31 ;
+32 ; .REGLST( A list of registry names (as subscripts)
+33 ; RegName) Registry IEN (output)
+34 ;
+35 ; Return values:
+36 ; <0 Error code
+37 ; 0 Ok
+38 ;
+39 ; This function removes names of those registries that are
+40 ; inactive or cannot be updated for any other reasons from
+41 ; the list. It also associates registry IENs with the names
+42 ; of registries remaining on the list.
+43 ;
+44 ; Moreover, it records corresponding messages about skipped
+45 ; registries to the current open log.
+46 ;
ARLST(REGLST) ;
+1 NEW INFO,RC,REGIEN,REGNAME,RORBUF,TMP
KILL DSTLST
+2 SET REGNAME=""
SET RC=0
+3 FOR
SET REGNAME=$ORDER(REGLST(REGNAME))
if REGNAME=""
QUIT
Begin DoDot:1
+4 SET REGIEN=$$REGIEN(REGNAME,"@;11I;21.05I",.RORBUF)
+5 ;--- Cannot find (or load) the registry parameters
+6 IF REGIEN'>0
Begin DoDot:2
+7 DO ERROR^RORERR(REGIEN,,REGNAME)
+8 KILL REGLST(REGNAME)
End DoDot:2
QUIT
+9 ;--- Check if the registry is marked as 'inactive'
+10 IF $GET(RORBUF("DILIST","ID",1,11))
Begin DoDot:2
+11 DO ERROR^RORERR(-48,,,,REGNAME)
+12 KILL REGLST(REGNAME)
End DoDot:2
QUIT
+13 ;--- Check if the registry has not been populated
+14 IF '$GET(RORBUF("DILIST","ID",1,21.05))
IF '$GET(RORPARM("SETUP"))
Begin DoDot:2
+15 DO TEXT^RORTXT(7980000.02,.INFO)
+16 DO ERROR^RORERR(-103,,.INFO,,REGNAME)
+17 KILL INFO,REGLST(REGNAME)
End DoDot:2
QUIT
+18 ;--- Store the registry IEN
+19 SET REGLST(REGNAME)=REGIEN
End DoDot:1
if RC<0
QUIT
+20 QUIT RC
+21 ;
+22 ;***** RETURNS A FULL NATIONAL ICN OF THE PATIENT
+23 ;
+24 ; PTIEN Patient IEN
+25 ;
+26 ; Return Values:
+27 ; <0 Error code
+28 ; "" ICN has not been assigned or ICN is a local ICN
+29 ; >0 Patient National ICN
+30 ;
ICN(PTIEN) ;
+1 NEW ICN,L,TMP
+2 IF $$IFLOCAL^MPIF001(PTIEN)
QUIT ""
+3 SET ICN=$$GETICN^MPIF001(PTIEN)
+4 IF ICN'>0
Begin DoDot:1
+5 SET TMP=$$ERROR^RORERR(-57,,$PIECE(ICN,U,2),PTIEN,+ICN,"$$GETICN^MPIF001")
End DoDot:1
QUIT ""
+6 ;--- Validate the checksum (just in case ;-)
+7 SET L=$LENGTH($PIECE(ICN,"V",2))
+8 QUIT $SELECT(L<6:$PIECE(ICN,"V")_"V"_$EXTRACT("000000",1,6-L)_$PIECE(ICN,"V",2),1:ICN)
+9 ;
PACT(DFN) ;returns ien & name of pc team PATCH 30
+1 ; DFN - pointer to patient file
+2 ; Date of interest (Default=DT)
+3 ;
+4 QUIT $PIECE($$OUTPTTM^SDUTL3(DFN,DT),U,2)
+5 ;
PCP(DFN) ;returns ien & name of pract filling pc position PATCH 30
+1 ; DFN - pointer to patient file
+2 ; DATE - date of interest
+3 ; PCROLE - Practitioner Position where '1' = PC provider ; '2' = PC attending
+4 ; '3' = PC associate provider
+5 ;
+6 ; returns (ien^name), or "" if none or -1 if error
+7 ;
+8 ;
+9 QUIT $PIECE($$OUTPTPR^SDUTL3(DFN,DT,1),"^",2)
+10 ;
FUTAPPT(DFN,DAYS) ; PATCH 33
+1 NEW RORAPPTDT,RORAPPTCNE,VASD
+2 IF $DATA(DAYS)
Begin DoDot:1
+3 NEW X,X1,X2
+4 DO NOW^%DTC
SET (VASD("F"),X1)=X
SET X2=DAYS
DO C^%DTC
SET VASD("T")=X
+5 SET VASD("W")="1"
+6 DO SDA^VADPT
End DoDot:1
+7 ;patch 34 change
IF $DATA(^UTILITY("VASD",$JOB))
Begin DoDot:1
+8 ;appt d/t
SET RORAPPTDT=$$DATE^RORXU002($PIECE($GET(^UTILITY("VASD",$JOB,1,"I")),U,1)\1)
+9 ;appt clinic name (external)
SET RORAPPTCNE=$PIECE($GET(^UTILITY("VASD",$JOB,1,"E")),U,2)
End DoDot:1
QUIT RORAPPTDT_U_RORAPPTCNE
+10 ;I $D(^UTILITY("VASD",$J)) Q $$DATE^RORXU002($P($G(^UTILITY("VASD",$J,1,"I")),"^",1)\1) ;patch 33 code
+11 QUIT 0
+12 ;***** LOADS THE LAB RESULTS
+13 ;
+14 ; PTIEN Patient IEN
+15 ;
+16 ; SDT Start date of the results
+17 ; EDT End date of the results
+18 ;
+19 ; [ROR8DST] Closed root of the destination array
+20 ; (the ^TMP("RORTMP",$J) node, by default)
+21 ;
+22 ; Return values:
+23 ; <0 Error code
+24 ; 0 Ok
+25 ;
LABRSLTS(PTIEN,SDT,EDT,ROR8DST) ;
+1 NEW H7CH,RC,RORMSG,TMP
+2 if $GET(ROR8DST)=""
SET ROR8DST=$NAME(^TMP("RORTMP",$JOB))
+3 KILL @ROR8DST
+4 IF $DATA(RORLRC)<10
if $GET(RORLRC)=""
QUIT 0
+5 ;--- Get the Patient ID (ICN or SSN)
+6 SET PTID=$$PTID(PTIEN)
if PTID<0
QUIT PTID
+7 ;--- Get the Lab data
+8 SET H7CH=$GET(RORHL("FS"))_$GET(RORHL("ECH"))
+9 SET RC=$$GCPR^LA7QRY(PTID,SDT,EDT,.RORLRC,"*",.RORMSG,ROR8DST,H7CH)
+10 IF RC=""
IF $DATA(RORMSG)>1
Begin DoDot:1
+11 NEW ERR,I,LST
+12 SET (ERR,LST)=""
+13 FOR I=1:1
SET ERR=$ORDER(RORMSG(ERR))
if ERR=""
QUIT
Begin DoDot:2
+14 SET LST=LST_","_ERR
SET TMP=RORMSG(ERR)
+15 KILL RORMSG(ERR)
SET RORMSG(I)=TMP
End DoDot:2
+16 SET LST=$PIECE(LST,",",2,999)
if (LST=3)!(LST=99)
QUIT
+17 SET RC=$$ERROR^RORERR(-27,,.RORMSG,PTIEN)
End DoDot:1
+18 QUIT $SELECT(RC<0:RC,1:0)
+19 ;
+20 ;***** RETURNS THE LOINC CODE WITH THE CONTROL DIGIT
+21 ;
+22 ; LNCODE LOINC code
+23 ;
+24 ; Besides adding a control digit to the LOINC code, the function
+25 ; checks the code against the LAB LOINC file (#95.3).
+26 ;
+27 ; Return values:
+28 ; <0 Error code
+29 ; >0 LOINC code with the control digit
+30 ;
LNCODE(LNCODE) ;
+1 NEW RC,RORBUF,RORMSG
+2 DO FIND^DIC(95.3,,"@;.01E","X",$PIECE(LNCODE,"-"),2,"B",,,"RORBUF","RORMSG")
+3 if $GET(DIERR)
QUIT $$DBS^RORERR("RORMSG",-9,,,95.3)
+4 ; Non-existent code
IF $GET(RORBUF("DILIST",0))<1
Begin DoDot:1
+5 SET RC=$$ERROR^RORERR(-29,,,,LNCODE)
End DoDot:1
QUIT RC
+6 ; Duplicate records
IF $GET(RORBUF("DILIST",0))>1
Begin DoDot:1
+7 SET RC=$$ERROR^RORERR(-30,,,,LNCODE)
End DoDot:1
QUIT RC
+8 QUIT RORBUF("DILIST","ID",1,.01)
+9 ;
+10 ;***** LOCK/UNLOCK REGISTRIES BEING PROCESSED
+11 ;
+12 ; .REGLST Reference to a local array containing registry names
+13 ; as subscripts and optional registry IENs as values
+14 ; [MODE] 0 - Unlock (default), 1 - Lock
+15 ; [TO] LOCK timeout (3 sec by defualt)
+16 ; [NAME] Name of the process/task
+17 ;
+18 ; Return Values:
+19 ; <0 Error code
+20 ; 0 Some of the registries has been locked by another job
+21 ; 1 Ok
+22 ;
LOCKREG(REGLST,MODE,TO,NAME) ;
+1 if $DATA(REGLST)<10
QUIT 1
+2 NEW LOCKLST,RORLIST,RC,REGIEN,REGNAME
+3 NEW CT,FAILS,Q,Q0,Z
+4 ; RORLIST = 0 if less than 15 entries to lock
+5 ; = 1 if 15 or more entries to lock
+6 ; (n,x,y) = the array in LOCKLST(x,y) at that point
+7 ; (where n = the # identifying the set of 15
+8 ; registries being locked at one time)
+9 ; FAILS = <0 or 1 ... lock failed = 0 ... lock was successful
+10 SET REGNAME=""
SET CT=0
SET RORLIST=0
+11 FOR
SET REGNAME=$ORDER(REGLST(REGNAME))
if REGNAME=""
QUIT
Begin DoDot:1
+12 SET REGIEN=+$GET(REGLST(REGNAME))
+13 IF REGIEN'>0
SET REGIEN=$$REGIEN^RORUTL02(REGNAME)
if REGIEN'>0
QUIT
+14 SET CT=CT+1
+15 SET LOCKLST(798.1,REGIEN_",")=""
+16 ; Split the locks into smaller chunks every 15 entries
IF '(CT#15)
Begin DoDot:2
+17 MERGE RORLIST(CT/15)=LOCKLST
SET RORLIST=1
+18 KILL LOCKLST
End DoDot:2
End DoDot:1
if REGIEN<0
QUIT
+19 if $GET(REGIEN)<0
QUIT REGIEN
+20 IF RORLIST
IF $ORDER(LOCKLST(""))'=""
MERGE RORLIST((CT/15\1)+1)=LOCKLST
KILL LOCKLST
+21 if $DATA(LOCKLST)<10&'$ORDER(RORLIST(0))
QUIT 1
+22 IF $GET(MODE)
SET RC=0
Begin DoDot:1
+23 IF 'RORLIST
SET RC=$$LOCK^RORLOCK(.LOCKLST,,,+$GET(TO,3),$GET(NAME))
QUIT
+24 FOR Q=1:1
if '$DATA(RORLIST(Q))!RC
QUIT
Begin DoDot:2
+25 KILL LOCKLST
MERGE LOCKLST=RORLIST(Q)
+26 SET FAILS=$$LOCK^RORLOCK(.LOCKLST,,,+$GET(TO,3),$GET(NAME))
SET RC=FAILS
+27 ; If lock fails for at least one set of nodes [=1 or <0] - unlock previous locks
+28 IF FAILS
if Q>1
Begin DoDot:3
+29 FOR Q0=1:1:Q-1
KILL LOCKLST
MERGE LOCKLST=RORLIST(Q0)
SET Z=$$UNLOCK^RORLOCK(.LOCKLST)
End DoDot:3
End DoDot:2
End DoDot:1
+30 IF '$TEST
Begin DoDot:1
+31 IF 'RORLIST
SET RC=$$UNLOCK^RORLOCK(.LOCKLST)
QUIT
+32 SET RC=0
+33 FOR Q=1:1
KILL LOCKLST
if '$DATA(RORLIST(Q))
QUIT
Begin DoDot:2
+34 MERGE LOCKLST=RORLIST(Q)
SET FAILS=$$UNLOCK^RORLOCK(.LOCKLST)
+35 if FAILS
SET RC=FAILS
End DoDot:2
End DoDot:1
+36 QUIT $SELECT('RC:1,RC<0:RC,1:0)
+37 ;
+38 ;***** RETURNS A PATIENT ID (ICN OR SSN)
+39 ;
+40 ; PTIEN Patient IEN
+41 ;
+42 ; Return Values:
+43 ; <0 Error code
+44 ; "" Neither ICN nor SSN has been assigned
+45 ; >0 Patient ICN (or SSN if ICN is not available)
+46 ;
PTID(PTIEN) ;
+1 NEW L,PTID,RC,RORMSG
+2 SET PTID=$$GETICN^MPIF001(PTIEN)
+3 IF PTID>0
Begin DoDot:1
+4 ;--- Validate the checksum (just in case ;-)
+5 SET L=$LENGTH($PIECE(PTID,"V",2))
if L'<6
QUIT
+6 ;S RC=$$ERROR^RORERR(-59,,,PTIEN)
+7 SET $PIECE(PTID,"V",2)=$EXTRACT("000000",1,6-L)_$PIECE(PTID,"V",2)
End DoDot:1
QUIT PTID
+8 ;--- Get SSN if ICN is not available
+9 SET PTID=$$GET1^DIQ(2,PTIEN_",",.09,,,"RORMSG")
+10 if $GET(DIERR)
QUIT $$DBS^RORERR("RORMSG",-9,,PTIEN,2)
+11 QUIT PTID
+12 ;
+13 ;***** RETURNS IEN OF THE REGISTRY PARAMETERS
+14 ;
+15 ; REGNAME Name of the registry
+16 ; [FIELDS] List of fields (separated by semicolons) to load
+17 ; [.RORTRGT] Reference to a local variable where field values will
+18 ; be stored by the FIND^DIC call
+19 ;
+20 ; Return Values:
+21 ; <0 Error code
+22 ; >0 Registry parameters IEN
+23 ;
REGIEN(REGNAME,FIELDS,RORTRGT) ;
+1 NEW RC,REGIEN,RORMSG
KILL RORTRGT
+2 DO FIND^DIC(798.1,,"@;"_$GET(FIELDS),"UX",REGNAME,2,"B",,,"RORTRGT","RORMSG")
+3 if $GET(DIERR)
QUIT $$DBS^RORERR("RORMSG",-9,,,798.1)
+4 SET RC=+$GET(RORTRGT("DILIST",0))
+5 QUIT $SELECT(RC<1:-1,RC>1:-2,1:+RORTRGT("DILIST",2,1))
+6 ;
+7 ;***** RETURNS NUMBER OF RECORDS IN THE REGISTRY
+8 ;
+9 ; REGIEN Registry IEN
+10 ; [.LOWIEN] The smallest IEN will be returned via this parameter
+11 ; [.HIGHIEN] The biggest IEN will be returned via this parameter
+12 ;
+13 ; Return Values:
+14 ; <0 Error code
+15 ; 0 The registry is empty
+16 ; >0 Number of records in the registry
+17 ;
REGSIZE(REGIEN,LOWIEN,HIGHIEN) ;
+1 NEW I,NODE,NRE,RC,RORFDA,RORMSG
+2 SET NODE=$NAME(^RORDATA(798,"AC",REGIEN))
+3 SET LOWIEN=$ORDER(@NODE@(""))
+4 SET HIGHIEN=$ORDER(@NODE@(""),-1)
+5 ;--- Get number of records from the parameters
+6 SET NRE=$$GET1^DIQ(798.1,REGIEN_",",19.1,,,"RORMSG")
+7 if $GET(DIERR)
QUIT $$DBS^RORERR("RORMSG",-9,,,798.1,REGIEN)
+8 if NRE>0
QUIT NRE
+9 ;--- Count the records of the registry
+10 SET I=""
SET NRE=0
+11 FOR
SET I=$ORDER(@NODE@(I))
if I=""
QUIT
SET NRE=NRE+1
+12 ;--- Store the value in the parameters
+13 SET RORFDA(798.1,REGIEN_",",19.1)=NRE
+14 DO FILE^DIE("K","RORFDA","RORMSG")
+15 QUIT NRE
+16 ;
+17 ;***** CHECKS IF AN EMPLOYEE SHOULD BE SKIPPED
+18 ;
+19 ; PTIEN Patient IEN
+20 ;
+21 ; [.]REGIEN Registry IEN
+22 ;
+23 ; If you are going to call this function for several
+24 ; patients in a row (in a cycle), you can pass the
+25 ; second parameter by reference. This will eliminate
+26 ; repetitive access to the registry parameters (the
+27 ; REGIEN("SE") node will be used as a "cache" for the
+28 ; value of the EXCLUDE EMPLOYEES field).
+29 ;
+30 ; Return Values:
+31 ; 0 Patient can be added to the registry
+32 ; 1 Patient should be skipped
+33 ;
+34 ; The function checks if the patient is an employee and if he/she
+35 ; can be added to the registry (according to the value of the
+36 ; EXCLUDE EMPLOYEES field of the ROR REGISTRY PARAMETERS file).
+37 ;
SKIPEMPL(PTIEN,REGIEN) ;
+1 if '$$EMPL^DGSEC4(PTIEN,"P")
QUIT 0
+2 if '$DATA(REGIEN("SE"))
SET REGIEN("SE")=+$PIECE($GET(^ROR(798.1,+REGIEN,0)),U,10)
+3 QUIT +REGIEN("SE")
+4 ;
+5 ;***** RETURNS IEN OF THE SELECTION RULE
+6 ;
+7 ; RULENAME Name of the selection rule
+8 ; [FIELDS] List of fields (separated by semicolons) to load
+9 ; [.RORTRGT] Reference to a local variable where field values will
+10 ; be stored by the FIND^DIC call.
+11 ;
+12 ; Return Values:
+13 ; <0 Error code
+14 ; >0 Selection rule IEN
+15 ;
SRLIEN(RULENAME,FIELDS,RORTRGT) ;
+1 NEW RC,RULEIEN,RORMSG
KILL RORTRGT
+2 DO FIND^DIC(798.2,,"@;"_$GET(FIELDS),"X",RULENAME,2,"B",,,"RORTRGT","RORMSG")
+3 if $GET(DIERR)
QUIT $$DBS^RORERR("RORMSG",-9,,,798.2)
+4 SET RC=+$GET(RORTRGT("DILIST",0))
+5 QUIT $SELECT(RC<1:-3,RC>1:-4,1:+RORTRGT("DILIST",2,1))
