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

RORUTL02.m

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