- 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 Feb 18, 2025@23:10:22 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