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