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

RORUTL05.m

Go to the documentation of this file.
  1. RORUTL05 ;HCIOFO/SG - MISCELLANEOUS UTILITIES ; 1/26/07 4:24pm
  1. ;;1.5;CLINICAL CASE REGISTRIES;**1,2,18**;Feb 17, 2006;Build 25
  1. ;
  1. ; This routine uses the following IAs:
  1. ;
  1. ; #4493 Read the .01 field of the file #771.7 (private)
  1. ; #10040 Access to the HOSPITAL LOCATION file (supported)
  1. ; #10061 DEM^VADPT (supported)
  1. ;
  1. ;*************************************************************************
  1. ; --- ROUTINE MODIFICATION LOG ---
  1. ;
  1. ;PKG/PATCH DATE DEVELOPER MODIFICATION
  1. ;----------- ---------- ----------- ----------------------------------------
  1. ;ROR*1.5*18 AUG 2012 C RAY Added logic to quit if registry is
  1. ; local
  1. ;*************************************************************************
  1. ;
  1. Q
  1. ;
  1. ;***** CHECKS IF THE E-MAIL NOTIFICATION IS ENABLED
  1. ;
  1. ; REGIEN Registry IEN
  1. ;
  1. ; Return Values:
  1. ; 0 Do not send e-mail notifications
  1. ; 1 E-mail notifications are enabled
  1. ;
  1. CCRNTFY(REGIEN) ;
  1. N DOMAIN,RC
  1. ;--- Check if not a production account
  1. I $T(PROD^XUPROD)'="" Q:'$$PROD^XUPROD() 0
  1. ;--- Check the domain name
  1. S DOMAIN=$G(^XMB("NETNAME"))
  1. Q:DOMAIN'?1.E1".DOMAIN.EXT" 0
  1. Q:(DOMAIN?1"TEST.".E)!(DOMAIN?1"TST.".E) 0
  1. ;--- Registry-specific checks
  1. I $G(REGIEN)>0 S RC=1 D Q:'RC 0
  1. . N HL,HLECH,HLFS,HLQ,NAME,RORMSG
  1. . ;--- Get the HL7 protocol name
  1. . S NAME=$$GET1^DIQ(798.1,+REGIEN,13,,,"RORMSG") Q:NAME=""
  1. . ;--- Check the HL7 processing ID
  1. . D INIT^HLFNC2(NAME,.HL)
  1. . I $G(HL("PID"))'="",HL("PID")'="P" S RC=0 Q
  1. ;--- Notification is enabled (production account)
  1. Q 1
  1. ;
  1. ;***** CHECK IF THE PATIENT'S RECORD IN FILE #2 IS VALID
  1. ;
  1. ; DFN Patient IEN (in file #2)
  1. ;
  1. ; Return Values:
  1. ; <0 Error code
  1. ; 0 Ok
  1. ;
  1. CHKPTR(DFN,SILENT) ;
  1. N RC,VA,VADM,VAERR
  1. D VADEM(DFN)
  1. I $G(VADM(1))="" S RC=-102 D:'$G(SILENT) Q RC
  1. . D ERROR^RORERR(RC,,,,"PATIENT",DFN)
  1. Q 0
  1. ;
  1. ;***** DELETES ALL RECORDS FROM THE (SUB)FILE
  1. ;
  1. ; FILE File/Subfile number
  1. ; [IENS] IENS of the subfile
  1. ;
  1. ; Return Values:
  1. ; <0 Error code
  1. ; 0 Ok
  1. ;
  1. CLEAR(FILE,IENS) ;
  1. Q:'$$VFILE^DILFD(FILE) 0
  1. N DA,DIK,RC,ROOT,TMP
  1. S IENS=$G(IENS)
  1. ;--- Lock the (sub)file
  1. S RC=$$LOCK^RORLOCK(FILE,IENS)
  1. I RC D Q RC
  1. . S TMP=$$GET1^DID(FILE,,,"NAME",,"RORMSG")
  1. . S TMP=$S(TMP'="":"file",1:"subfile")_" #"_FILE
  1. . S:IENS'="" TMP=TMP_"; IENS: '"_IENS_"'"
  1. . S RC=$$ERROR^RORERR(-11,,"By "_$$TEXT^RORLOCK(RC),,TMP)
  1. ;
  1. ;--- Delete the records
  1. S DIK=$$ROOT^DILFD(FILE,IENS)
  1. S ROOT=$$CREF^DILF(DIK)
  1. D DA^DILF(IENS,.DA) S DA=0
  1. F S DA=$O(@ROOT@(DA)) Q:DA'>0 D ^DIK
  1. ;
  1. ;--- Unlock the (sub)file
  1. D UNLOCK^RORLOCK(FILE,IENS)
  1. Q $S(RC<0:RC,1:0)
  1. ;
  1. ;***** CLEARS THE FIELDS OF THE RECORDS FOUND BY NAME
  1. ;
  1. ; FILE File number
  1. ; [IENS] IENS of the subfile
  1. ; NAME Name of the record (value of the .01 field)
  1. ; FIELDS List of field numbers separated by semicolons
  1. ;
  1. ; Return Values:
  1. ; <0 Error code
  1. ; 0 Ok
  1. ;
  1. CLRFLDS(FILE,IENS,NAME,FIELDS) ;
  1. N FLD,I,IEN,IENS1,IS,RC,RORBUF,RORFDA,RORMSG
  1. ;--- Find the record(s)
  1. D FIND^DIC(FILE,$G(IENS),"@","X",NAME,,"B",,,"RORBUF","RORMSG")
  1. S RC=$$DBS^RORERR("RORMSG",-9,,,FILE) Q:RC<0 RC
  1. S:$G(IENS)="" IENS="," S FIELDS=$TR(FIELDS," ")
  1. ;--- Update the record(s)
  1. S IS="",RC=0
  1. F S IS=$O(RORBUF("DILIST",2,IS)) Q:IS="" D Q:RC<0
  1. . S IEN=RORBUF("DILIST",2,IS) Q:IEN'>0
  1. . S IENS1=IEN_IENS
  1. . F I=1:1 S FLD=$P(FIELDS,";",I) Q:FLD'>0 D
  1. . . S RORFDA(FILE,IENS1,+FLD)="@"
  1. . D FILE^DIE(,"RORFDA","RORMSG")
  1. . S RC=$$DBS^RORERR("RORMSG",-9,,,FILE,IENS1)
  1. Q $S(RC<0:RC,1:0)
  1. ;
  1. ;***** RETURNS THE END DATE FOR THE EVENT PURGE
  1. EPDATE() ;
  1. N DATE,IR,RC,RORBUF,RORMSG,TMP
  1. D LIST^DIC(798.1,,"@;1I;2I","U",,,,"B",,,"RORBUF","RORMSG")
  1. Q:$G(DIERR) $$DBS^RORERR("RORMSG",-9,,,798.1)
  1. ;--- Get the oldest date of registry updates
  1. S IR="",DATE=$$DT^XLFDT
  1. F S IR=$O(RORBUF("DILIST","ID",IR)) Q:IR="" D
  1. . S TMP=$G(RORBUF("DILIST","ID",IR,1)) ; REGISTRY UPDATED UNTIL
  1. . I TMP>0 S:TMP<DATE DATE=TMP
  1. . ;S TMP=$G(RORBUF("DILIST","ID",IR,2)) ; DATA EXTRACTED UNTIL
  1. . ;I TMP>0 S:TMP<DATE DATE=TMP
  1. ;--- Subtract additional 14 days (just in case)
  1. S DATE=$$FMADD^XLFDT(DATE\1,-14)
  1. ;--- No more than 60 days in the past
  1. S TMP=$$FMADD^XLFDT($$DT^XLFDT,-60)
  1. Q $S(DATE>TMP:DATE,1:TMP)
  1. ;
  1. ;***** RETURNS NAME OF THE HOSPITAL LOCATION
  1. ;
  1. ; HLIEN IEN of the hospital location
  1. ;
  1. HLNAME(HLIEN) ;
  1. N NAME
  1. S NAME=$$GET1^DIQ(44,(+HLIEN)_",",.01,,,"RORMSG")
  1. D:$G(DIERR) DBS^RORERR("RORMSG",-9,,,44,(+HLIEN)_",")
  1. Q NAME
  1. ;
  1. ;***** FORMATS THE TEXT THAT DESCRIBES STATUS OF THE HL7 MESSAGE
  1. ;
  1. ; MSGID A valid ID of the HL7 message
  1. ;
  1. ; .RORDST Reference to a local array that the text
  1. ; is appended to
  1. ;
  1. ; [TITLE] Title of the output
  1. ;
  1. ; [DLGNUM] Number of an entry in the DIALOG file that
  1. ; contains the text template (by default,
  1. ; the 7980000.004 is used)
  1. ;
  1. ; [.PARAMS] Reference to a local variable containing
  1. ; additional parameters that substitute the
  1. ; placeholders in the text template
  1. ; PARAMS(
  1. ; "NOR") Number of retries to resend the message
  1. ; "REGISTRY") Name of the registry
  1. ;
  1. ; [MSGSTAT] Status of the message (result value of the
  1. ; $$MSGSTAT^HLUTIL function). If this parameter
  1. ; is undefined or equal to an empty string, the
  1. ; current status of the message is retrieved.
  1. ;
  1. MSG7STS(MSGID,RORDST,TITLE,DLGNUM,PARAMS,MSGSTAT) ;
  1. N RORMSG,TMP
  1. Q:$G(MSGID)?." "
  1. S:$G(MSGSTAT)="" MSGSTAT=$$MSGSTAT^HLUTIL(MSGID)
  1. ;--- Prepare the parameters
  1. S PARAMS("ID")=MSGID
  1. S PARAMS("STATUS")=$$MSGSTXT^RORHL7A(MSGSTAT)
  1. S TMP=+$P(MSGSTAT,U,2)
  1. S:TMP>0 PARAMS("UPDATED")=$$FMTE^XLFDT(TMP)
  1. S PARAMS("ERRMSG")=$P(MSGSTAT,U,3)
  1. S TMP=+$P(MSGSTAT,U,4)
  1. S:TMP>0 PARAMS("ERRTYPE")=$$GET1^DIQ(771.7,TMP_",",.01,,,"RORMSG")
  1. S PARAMS($S(+MSGSTAT=1:"QPOS",1:"RETRIES"))=$P(MSGSTAT,U,5)
  1. S PARAMS("OPENFAIL")=$P(MSGSTAT,U,6)
  1. S PARAMS("ACK")=$P(MSGSTAT,U,7)
  1. ;--- Additional parameters
  1. I $G(DLGNUM)>0 D
  1. . S PARAMS("STATCODE")=+MSGSTAT
  1. . S TMP=+$P(MSGSTAT,U,2)
  1. . S:TMP>0 PARAMS("STATUPD")=$$FMTHL7^XLFDT(TMP)
  1. . S TMP=$$SITE^RORUTL03()
  1. . S PARAMS("STNAME")=$P(TMP,U,2)
  1. . S PARAMS("STNUM")=$P(TMP,U)
  1. . S:$G(PARAMS("NOR"))'>0 PARAMS("NOR")="several"
  1. . S:$G(PARAMS("REGISTRY"))="" PARAMS("REGISTRY")="<unknown>"
  1. E S DLGNUM=7980000.004
  1. ;--- Build the text
  1. S:$G(TITLE)'="" RORDST(1)=TITLE,RORDST(2)=" "
  1. D BLD^DIALOG(DLGNUM,.PARAMS,,"RORDST","S")
  1. Q
  1. ;
  1. ;***** CHECK IF THE ARGUMENT IS A NUMBER
  1. ;
  1. ; Return Values:
  1. ; 1 Value starts from a number
  1. ; 0 Otherwise
  1. ;
  1. NUMERIC(VAL,NUMVAL) ;
  1. S NUMVAL=$$TRIM^XLFSTR(VAL)
  1. I NUMVAL?.1(1"+",1"-")1(1.N.1".".N,.N.1"."1.N).1(1"E".1(1"+",1"-")1.N) S NUMVAL=+NUMVAL Q 1
  1. S NUMVAL=""
  1. Q 0
  1. ;
  1. ;***** MARKS THE REGISTRY RECORDS FOR RESENDING THE LOCAL DATA
  1. ;
  1. ; .REGLST Reference to a local array containing registry names
  1. ; as subscripts and optional registry IENs as values
  1. ;
  1. ; WD Number of days to wait before marking the records
  1. ; for resending the local registry data
  1. ;
  1. ; Return Values:
  1. ; <0 Error code
  1. ; 0 Ok
  1. ;
  1. REMARK(REGLST,WD) ;
  1. N DATE,IEN,IENS,REGIEN,REGNAME,ROOT,RORFDA,RORMSG,TMP
  1. S ROOT=$$ROOT^DILFD(798,,1),RC=0
  1. S DATE=$$FMADD^XLFDT($$DT^XLFDT,-WD)
  1. ;--- Process the registries from the list
  1. S REGNAME=""
  1. F S REGNAME=$O(REGLST(REGNAME)) Q:REGNAME="" D
  1. . S REGIEN=+REGLST(REGNAME)
  1. . I REGIEN'>0 S REGIEN=$$REGIEN^RORUTL02(REGNAME) Q:REGIEN'>0
  1. . ;--- quit if local registry
  1. . Q:'+($P($G(^ROR(798.1,REGIEN,0)),U,11))
  1. . S IENS=REGIEN_","
  1. . ;--- Get the registry parameters
  1. . D GETS^DIQ(798.1,IENS,"21.04;21.05","I","RORFDA","RORMSG")
  1. . I $G(DIERR) S TMP=$$DBS^RORERR("RORMSG",-9,,,798.1,IENS) Q
  1. . ;--- Local data has been resent already
  1. . Q:$G(RORFDA(798.1,IENS,21.04,"I"))
  1. . ;--- The registry has not been populated yet
  1. . Q:'$G(RORFDA(798.1,IENS,21.05,"I"))
  1. . ;--- It is too early for resending the local data
  1. . Q:RORFDA(798.1,IENS,21.05,"I")>DATE
  1. . K RORFDA,RORMSG
  1. . ;--- Mark registry records as modified
  1. . S IEN=0
  1. . F S IEN=$O(@ROOT@("AC",REGIEN,IEN)) Q:'IEN D
  1. . . S IENS=IEN_","
  1. . . S RORFDA(798,IENS,4)=1 ; UPDATE DEMOGRAPHICS
  1. . . S RORFDA(798,IENS,5)=1 ; UPDATE LOCAL REGISTRY DATA
  1. . . D FILE^DIE(,"RORFDA","RORMSG")
  1. . . D:$G(DIERR) DBS^RORERR("RORMSG",-9,,,798,IENS)
  1. . ;--- Update registry parameters
  1. . S IENS=REGIEN_","
  1. . S RORFDA(798.1,IENS,21.04)=$$NOW^XLFDT
  1. . D FILE^DIE("K","RORFDA","RORMSG")
  1. . I $G(DIERR) S TMP=$$DBS^RORERR("RORMSG",-9,,,798.1,IENS) Q
  1. . ;--- Record the message
  1. . S TMP="Local registry and demographic data will be resent to AAC"
  1. . D LOG^RORLOG(2,TMP,,"Registry Name: "_REGNAME)
  1. Q 0
  1. ;
  1. ;***** CALLS THE DEM^VADPT
  1. ;
  1. ; DFN Patient IEN (in file #2)
  1. ; VALIDATE Make sure that required fields are not empty
  1. ; VAPTYP
  1. ; VAHOW
  1. ;
  1. VADEM(DFN,VALIDATE,VAPTYP,VAHOW) ;
  1. N I,J,X,A,K,K1,NC,NF,NQ,T,VAROOT
  1. D DEM^VADPT
  1. S VA("BID")=$E($P($G(VADM(2)),U),6,10) ; Always 'Last4'
  1. Q:'$G(VALIDATE)
  1. ;--- Make sure that required fields are not empty
  1. S:$G(VADM(1))="" VADM(1)="Unknown ("_DFN_")"
  1. S:$G(VA("BID"))="" VA("BID")="UNKN"
  1. Q