RORUPD51 ;HCIOFO/SG - UPDATE PATIENT'S DEMOGRAPHIC DATA (1) ; 7/6/06 11:15am
;;1.5;CLINICAL CASE REGISTRIES;**1**;Feb 17, 2006;Build 24
;
Q
;
;***** MARKS REGISTRIES (UPDATE DEMOGRAPHICS)
;
; PTIEN Patient IEN
; [DOD] Date of death
;
; Return Values:
; <0 Error code
; 0 Ok
;
MARKREGS(PTIEN,DOD) ;
N ACTIVE,ECNT,I,IENS,RC,RI,TMP
N RORBUF,RORFDA,RORMSG,RORSRC
;--- Compile a list of associated registries
D FIND^DIC(798,,"@","QUX",PTIEN,,"B",,,"RORBUF","RORMSG")
Q:$G(DIERR) $$DBS^RORERR("RORMSG",-9,,PTIEN,798)
;--- Mark patient records of the registries
S RI="",ECNT=0
F S RI=$O(RORBUF("DILIST",2,RI)) Q:RI="" D L -^RORDATA(798,+IENS)
. S IENS=RORBUF("DILIST",2,RI)_","
. K RORFDA,RORSRC
. ;--- Try to lock the record; if this fails, continue anyway
. L +^RORDATA(798,+IENS):3
. ;--- Load the field values
. D GETS^DIQ(798,IENS,"4;8","EI","RORSRC","RORMSG")
. I $G(DIERR) D S ECNT=ECNT+1 Q
. . S RC=$$DBS^RORERR("RORMSG",-9,,PTIEN,798,IENS)
. S ACTIVE=+$G(RORSRC(798,IENS,8,"E"))
. ;--- Do not mark again if already marked
. I '$G(RORSRC(798,IENS,4,"I")) S RC=0 D Q:RC<0
. . ;--- Mark only active records
. . S:ACTIVE RORFDA(798,IENS,4)=1
. ;--- Update registry data record
. I $D(RORFDA)>1 S RC=0 D Q:RC<0
. . D FILE^DIE(,"RORFDA","RORMSG")
. . I $G(DIERR) D S ECNT=ECNT+1
. . . S RC=$$DBS^RORERR("RORMSG",-9,,PTIEN,798,IENS)
Q $S(ECNT>0:-9,1:0)
;
;***** PROCESSES THE MERGED PATIENT RECORD
;
; DFN IEN of the merged record (medrged from)
; NEWDFN New patient IEN (merged to)
;
; Return values:
; <0 Error code
; 0 Ok
;
MERGE(DFN,NEWDFN) ;
N DA,DIK,DTNEW,DTOLD,IEN,IENS,IR,PTIEN,REGIEN,REGLST,RORBUF,RORFDA,RORMSG,TMP
D LOG^RORERR(-111,,,DFN,NEWDFN)
;=== Get the lists of registry records associated with the
;=== merged from ("from") and merged to ("to") patient data
F PTIEN=DFN,NEWDFN D Q:RC<0
. K RORBUF,RORMSG
. D FIND^DIC(798,,"@;.02I;1I","QUX",PTIEN,,"B",,,"RORBUF","RORMSG")
. I $G(DIERR) S RC=$$DBS^RORERR("RORMSG",-9,,PTIEN,798) Q
. S IR=0
. F S IR=$O(RORBUF("DILIST",2,IR)) Q:IR'>0 D Q:RC<0
. . S IEN=+RORBUF("DILIST",2,IR)
. . S REGIEN=+$G(RORBUF("DILIST","ID",IR,.02))
. . I REGIEN'>0 S RC=$$ERROR^RORERR(-95,,,PTIEN,798,IEN_",",.02) Q
. . S TMP=+$G(RORBUF("DILIST","ID",IR,1))
. . I TMP'>0 S RC=$$ERROR^RORERR(-95,,,PTIEN,798,IEN_",",1) Q
. . S REGLST(PTIEN,REGIEN)=IEN_U_TMP
Q:RC<0 RC
;=== Compare the "from" and "to" registry records
S REGIEN=0
F S REGIEN=$O(REGLST(DFN,REGIEN)) Q:REGIEN'>0 D
. K RORFDA,RORMSG S RC=0
. S DTOLD=+$P(REGLST(DFN,REGIEN),U,2)
. S DTNEW=+$P($G(REGLST(NEWDFN,REGIEN)),U,2)
. I (DTNEW'>0)!(DTOLD<DTNEW) D Q:RC<0
. . ;--- Make sure that the "to" patient has a record
. . ;--- in the ROR PATIENT file.
. . S RC=$$ADDPDATA^RORUPD50(NEWDFN) Q:RC<0
. . ;--- Replace the .01 value in the "from" registry record with
. . ; the new patient pointer since there is either no other
. . ;--- record for this patient or it is newer than the "from" one.
. . S IENS=+$P(REGLST(DFN,REGIEN),U)_","
. . S RORFDA(798,IENS,.01)=NEWDFN
. . D FILE^DIE(,"RORFDA","RORMSG")
. . I $G(DIERR) S RC=$$DBS^RORERR("RORMSG",-9,,DFN,798,IENS) Q
. . ;--- Delete the "to" registry record. It was created after
. . ;--- the original ("from") one and we should keep the latter.
. . S DA=+$P($G(REGLST(NEWDFN,REGIEN)),U)
. . I DA>0 S DIK=$$ROOT^DILFD(798) D ^DIK
. E D
. . ;--- Delete the "from" registry record since
. . ;--- the "to" record is actually older
. . S DIK=$$ROOT^DILFD(798),DA=+$P(REGLST(DFN,REGIEN),U) D ^DIK
. ;--- Indicate successful merge
. K REGLST(DFN,REGIEN)
;=== Done
Q 0
;
;***** SCANS PATIENTS AND UPDATES DEMOGRAPHIC DATA (IF NECESSARY)
;
; .REGLST Reference to a local array containing
; registry names as subscripts
;
; Return Values:
; <0 Error code
; 0 Ok
;
UPDDEM(REGLST) ;
N CNT,IR,PTIEN,RC,REGIEN,REGNAME,ROOT,SCR,UPD,UPDCNT
N RORLOR,RORLST,RORMSG
S ROOT=$$ROOT^DILFD(798,,1)
;--- Compile a list of registry internal entry numbers
S REGNAME="",RC=0
F S REGNAME=$O(REGLST(REGNAME)) Q:REGNAME="" D Q:RC<0
. S RC=+$G(REGLST(REGNAME))
. S:RC'>0 RC=$$REGIEN^RORUTL02(REGNAME)
. S:RC>0 RORLOR(+RC)=""
Q:RC<0 RC
;--- Loop through the patients of the registries
S PTIEN="",(CNT,RC)=0
F S PTIEN=$O(@ROOT@("B",PTIEN)) Q:PTIEN="" D Q:RC<0
. ;--- Check if task stop has been requested
. I $D(ZTQUEUED),$$S^%ZTLOAD D Q
. . S RC=$$ERROR^RORERR(-42)
. S CNT=CNT+1
. I $G(RORPARM("DEBUG"))>1 W:$E($G(IOST),1,2)="C-" *13,CNT
. ;--- Check for "stray" items in the cross-reference
. S IR=""
. F S IR=$O(@ROOT@("B",PTIEN,IR)) Q:IR="" D
. . K:$P($G(@ROOT@(IR,0)),U)'>0 @ROOT@("B",PTIEN,IR)
. Q:$D(@ROOT@("B",PTIEN))<10
. ;--- Check for a merged patient record
. S RC=$$MERGED^RORUTL18(PTIEN)
. I RC S:RC>0 RC=$$MERGE(PTIEN,RC) S RC=0 Q
. ;--- Load a list of patient's registry records
. S SCR="S Y=+$P($G(^(0)),U,2) I Y,$D(RORLOR(Y))"
. D FIND^DIC(798,,"@;.02I;3I;8E","QUX",PTIEN,,"B",SCR,,"RORLST","RORMSG")
. I $G(DIERR) D Q
. . S RC=$$DBS^RORERR("RORMSG",-9,,PTIEN,798)
. ;--- Demographic data should be checked only if at least one of
. ;--- the registry records of the patient is active.
. S IR="",UPDCNT=0
. F S IR=$O(RORLST("DILIST","ID",IR)) Q:IR="" D
. . S UPD=+$G(RORLST("DILIST","ID",IR,8))
. . S REGIEN=+$G(RORLST("DILIST","ID",IR,.02))
. . S TMP=+$G(RORLST("DILIST","ID",IR,3)) ; STATUS
. . S CNT(REGIEN,TMP)=$G(CNT(REGIEN,TMP))+1
. . S:UPD UPDCNT=UPDCNT+1
. S:UPDCNT RC=$$UPDPTDEM(PTIEN)
D:RC'<0 UPDRCNT(.CNT)
;---
Q $S(RC<0:RC,1:0)
;
;***** UPDATES DEMOGRAPHIC DATA OF THE PATIENT (IF NECESSARY)
;
; PTIEN Patient IEN
;
; Return Values:
; <0 Error code
; 0 Ok
;
UPDPTDEM(PTIEN) ;
N CF,DOD,IENS,RC,RORMSG,RORPAT
S IENS=PTIEN_",",CF=0
;--- Try to lock the record of the ROR PATIENT file
L +^RORDATA(798.4,PTIEN):3
E Q $$ERROR^RORERR(-11,,,PTIEN,"file #798.4")
D
. ;--- Compare demographic data
. S RC=$$PATDATA^RORUPD52(IENS,.RORPAT,IENS,.DOD) Q:RC<0
. S:RC CF=1
. ;--- Mark registry records of the patient
. I CF S RC=$$MARKREGS(PTIEN,$G(DOD)) Q:RC<0
. ;--- Update demographic data
. I CF,$D(RORPAT)>1 S RC=0 D Q:RC<0
. . D FILE^DIE(,"RORPAT","RORMSG") Q:'$G(DIERR)
. . S RC=$$DBS^RORERR("RORMSG",-9,,PTIEN,798.4)
;
L -^RORDATA(798.4,PTIEN)
Q 0
;
;***** UPDATES RECORD COUNTERS IN THE 'ROR REGISTRY PARAMETERS' FILE
;
; .CNT( Reference to a local array containg registry
; record counters
; Registry#,
; 0) Number of confirmed records
; 4) Number of pending records
;
UPDRCNT(CNT) ;
N IENS,RC,REGIEN,RORFDA,RORMSG
S REGIEN=0
F S REGIEN=$O(CNT(REGIEN)) Q:REGIEN="" D
. S IENS=REGIEN_","
. S RORFDA(798.1,IENS,19.1)=$G(CNT(REGIEN,0))
. S RORFDA(798.1,IENS,19.2)=$G(CNT(REGIEN,4))
. D FILE^DIE("K","RORFDA","RORMSG")
. I $G(DIERR) D Q
. . S RC=$$DBS^RORERR("RORMSG",-9,,798.1,IENS)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORUPD51 7259 printed Dec 13, 2024@01:43:46 Page 2
RORUPD51 ;HCIOFO/SG - UPDATE PATIENT'S DEMOGRAPHIC DATA (1) ; 7/6/06 11:15am
+1 ;;1.5;CLINICAL CASE REGISTRIES;**1**;Feb 17, 2006;Build 24
+2 ;
+3 QUIT
+4 ;
+5 ;***** MARKS REGISTRIES (UPDATE DEMOGRAPHICS)
+6 ;
+7 ; PTIEN Patient IEN
+8 ; [DOD] Date of death
+9 ;
+10 ; Return Values:
+11 ; <0 Error code
+12 ; 0 Ok
+13 ;
MARKREGS(PTIEN,DOD) ;
+1 NEW ACTIVE,ECNT,I,IENS,RC,RI,TMP
+2 NEW RORBUF,RORFDA,RORMSG,RORSRC
+3 ;--- Compile a list of associated registries
+4 DO FIND^DIC(798,,"@","QUX",PTIEN,,"B",,,"RORBUF","RORMSG")
+5 if $GET(DIERR)
QUIT $$DBS^RORERR("RORMSG",-9,,PTIEN,798)
+6 ;--- Mark patient records of the registries
+7 SET RI=""
SET ECNT=0
+8 FOR
SET RI=$ORDER(RORBUF("DILIST",2,RI))
if RI=""
QUIT
Begin DoDot:1
+9 SET IENS=RORBUF("DILIST",2,RI)_","
+10 KILL RORFDA,RORSRC
+11 ;--- Try to lock the record; if this fails, continue anyway
+12 LOCK +^RORDATA(798,+IENS):3
+13 ;--- Load the field values
+14 DO GETS^DIQ(798,IENS,"4;8","EI","RORSRC","RORMSG")
+15 IF $GET(DIERR)
Begin DoDot:2
+16 SET RC=$$DBS^RORERR("RORMSG",-9,,PTIEN,798,IENS)
End DoDot:2
SET ECNT=ECNT+1
QUIT
+17 SET ACTIVE=+$GET(RORSRC(798,IENS,8,"E"))
+18 ;--- Do not mark again if already marked
+19 IF '$GET(RORSRC(798,IENS,4,"I"))
SET RC=0
Begin DoDot:2
+20 ;--- Mark only active records
+21 if ACTIVE
SET RORFDA(798,IENS,4)=1
End DoDot:2
if RC<0
QUIT
+22 ;--- Update registry data record
+23 IF $DATA(RORFDA)>1
SET RC=0
Begin DoDot:2
+24 DO FILE^DIE(,"RORFDA","RORMSG")
+25 IF $GET(DIERR)
Begin DoDot:3
+26 SET RC=$$DBS^RORERR("RORMSG",-9,,PTIEN,798,IENS)
End DoDot:3
SET ECNT=ECNT+1
End DoDot:2
if RC<0
QUIT
End DoDot:1
LOCK -^RORDATA(798,+IENS)
+27 QUIT $SELECT(ECNT>0:-9,1:0)
+28 ;
+29 ;***** PROCESSES THE MERGED PATIENT RECORD
+30 ;
+31 ; DFN IEN of the merged record (medrged from)
+32 ; NEWDFN New patient IEN (merged to)
+33 ;
+34 ; Return values:
+35 ; <0 Error code
+36 ; 0 Ok
+37 ;
MERGE(DFN,NEWDFN) ;
+1 NEW DA,DIK,DTNEW,DTOLD,IEN,IENS,IR,PTIEN,REGIEN,REGLST,RORBUF,RORFDA,RORMSG,TMP
+2 DO LOG^RORERR(-111,,,DFN,NEWDFN)
+3 ;=== Get the lists of registry records associated with the
+4 ;=== merged from ("from") and merged to ("to") patient data
+5 FOR PTIEN=DFN,NEWDFN
Begin DoDot:1
+6 KILL RORBUF,RORMSG
+7 DO FIND^DIC(798,,"@;.02I;1I","QUX",PTIEN,,"B",,,"RORBUF","RORMSG")
+8 IF $GET(DIERR)
SET RC=$$DBS^RORERR("RORMSG",-9,,PTIEN,798)
QUIT
+9 SET IR=0
+10 FOR
SET IR=$ORDER(RORBUF("DILIST",2,IR))
if IR'>0
QUIT
Begin DoDot:2
+11 SET IEN=+RORBUF("DILIST",2,IR)
+12 SET REGIEN=+$GET(RORBUF("DILIST","ID",IR,.02))
+13 IF REGIEN'>0
SET RC=$$ERROR^RORERR(-95,,,PTIEN,798,IEN_",",.02)
QUIT
+14 SET TMP=+$GET(RORBUF("DILIST","ID",IR,1))
+15 IF TMP'>0
SET RC=$$ERROR^RORERR(-95,,,PTIEN,798,IEN_",",1)
QUIT
+16 SET REGLST(PTIEN,REGIEN)=IEN_U_TMP
End DoDot:2
if RC<0
QUIT
End DoDot:1
if RC<0
QUIT
+17 if RC<0
QUIT RC
+18 ;=== Compare the "from" and "to" registry records
+19 SET REGIEN=0
+20 FOR
SET REGIEN=$ORDER(REGLST(DFN,REGIEN))
if REGIEN'>0
QUIT
Begin DoDot:1
+21 KILL RORFDA,RORMSG
SET RC=0
+22 SET DTOLD=+$PIECE(REGLST(DFN,REGIEN),U,2)
+23 SET DTNEW=+$PIECE($GET(REGLST(NEWDFN,REGIEN)),U,2)
+24 IF (DTNEW'>0)!(DTOLD<DTNEW)
Begin DoDot:2
+25 ;--- Make sure that the "to" patient has a record
+26 ;--- in the ROR PATIENT file.
+27 SET RC=$$ADDPDATA^RORUPD50(NEWDFN)
if RC<0
QUIT
+28 ;--- Replace the .01 value in the "from" registry record with
+29 ; the new patient pointer since there is either no other
+30 ;--- record for this patient or it is newer than the "from" one.
+31 SET IENS=+$PIECE(REGLST(DFN,REGIEN),U)_","
+32 SET RORFDA(798,IENS,.01)=NEWDFN
+33 DO FILE^DIE(,"RORFDA","RORMSG")
+34 IF $GET(DIERR)
SET RC=$$DBS^RORERR("RORMSG",-9,,DFN,798,IENS)
QUIT
+35 ;--- Delete the "to" registry record. It was created after
+36 ;--- the original ("from") one and we should keep the latter.
+37 SET DA=+$PIECE($GET(REGLST(NEWDFN,REGIEN)),U)
+38 IF DA>0
SET DIK=$$ROOT^DILFD(798)
DO ^DIK
End DoDot:2
if RC<0
QUIT
+39 IF '$TEST
Begin DoDot:2
+40 ;--- Delete the "from" registry record since
+41 ;--- the "to" record is actually older
+42 SET DIK=$$ROOT^DILFD(798)
SET DA=+$PIECE(REGLST(DFN,REGIEN),U)
DO ^DIK
End DoDot:2
+43 ;--- Indicate successful merge
+44 KILL REGLST(DFN,REGIEN)
End DoDot:1
+45 ;=== Done
+46 QUIT 0
+47 ;
+48 ;***** SCANS PATIENTS AND UPDATES DEMOGRAPHIC DATA (IF NECESSARY)
+49 ;
+50 ; .REGLST Reference to a local array containing
+51 ; registry names as subscripts
+52 ;
+53 ; Return Values:
+54 ; <0 Error code
+55 ; 0 Ok
+56 ;
UPDDEM(REGLST) ;
+1 NEW CNT,IR,PTIEN,RC,REGIEN,REGNAME,ROOT,SCR,UPD,UPDCNT
+2 NEW RORLOR,RORLST,RORMSG
+3 SET ROOT=$$ROOT^DILFD(798,,1)
+4 ;--- Compile a list of registry internal entry numbers
+5 SET REGNAME=""
SET RC=0
+6 FOR
SET REGNAME=$ORDER(REGLST(REGNAME))
if REGNAME=""
QUIT
Begin DoDot:1
+7 SET RC=+$GET(REGLST(REGNAME))
+8 if RC'>0
SET RC=$$REGIEN^RORUTL02(REGNAME)
+9 if RC>0
SET RORLOR(+RC)=""
End DoDot:1
if RC<0
QUIT
+10 if RC<0
QUIT RC
+11 ;--- Loop through the patients of the registries
+12 SET PTIEN=""
SET (CNT,RC)=0
+13 FOR
SET PTIEN=$ORDER(@ROOT@("B",PTIEN))
if PTIEN=""
QUIT
Begin DoDot:1
+14 ;--- Check if task stop has been requested
+15 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
Begin DoDot:2
+16 SET RC=$$ERROR^RORERR(-42)
End DoDot:2
QUIT
+17 SET CNT=CNT+1
+18 IF $GET(RORPARM("DEBUG"))>1
if $EXTRACT($GET(IOST),1,2)="C-"
WRITE *13,CNT
+19 ;--- Check for "stray" items in the cross-reference
+20 SET IR=""
+21 FOR
SET IR=$ORDER(@ROOT@("B",PTIEN,IR))
if IR=""
QUIT
Begin DoDot:2
+22 if $PIECE($GET(@ROOT@(IR,0)),U)'>0
KILL @ROOT@("B",PTIEN,IR)
End DoDot:2
+23 if $DATA(@ROOT@("B",PTIEN))<10
QUIT
+24 ;--- Check for a merged patient record
+25 SET RC=$$MERGED^RORUTL18(PTIEN)
+26 IF RC
if RC>0
SET RC=$$MERGE(PTIEN,RC)
SET RC=0
QUIT
+27 ;--- Load a list of patient's registry records
+28 SET SCR="S Y=+$P($G(^(0)),U,2) I Y,$D(RORLOR(Y))"
+29 DO FIND^DIC(798,,"@;.02I;3I;8E","QUX",PTIEN,,"B",SCR,,"RORLST","RORMSG")
+30 IF $GET(DIERR)
Begin DoDot:2
+31 SET RC=$$DBS^RORERR("RORMSG",-9,,PTIEN,798)
End DoDot:2
QUIT
+32 ;--- Demographic data should be checked only if at least one of
+33 ;--- the registry records of the patient is active.
+34 SET IR=""
SET UPDCNT=0
+35 FOR
SET IR=$ORDER(RORLST("DILIST","ID",IR))
if IR=""
QUIT
Begin DoDot:2
+36 SET UPD=+$GET(RORLST("DILIST","ID",IR,8))
+37 SET REGIEN=+$GET(RORLST("DILIST","ID",IR,.02))
+38 ; STATUS
SET TMP=+$GET(RORLST("DILIST","ID",IR,3))
+39 SET CNT(REGIEN,TMP)=$GET(CNT(REGIEN,TMP))+1
+40 if UPD
SET UPDCNT=UPDCNT+1
End DoDot:2
+41 if UPDCNT
SET RC=$$UPDPTDEM(PTIEN)
End DoDot:1
if RC<0
QUIT
+42 if RC'<0
DO UPDRCNT(.CNT)
+43 ;---
+44 QUIT $SELECT(RC<0:RC,1:0)
+45 ;
+46 ;***** UPDATES DEMOGRAPHIC DATA OF THE PATIENT (IF NECESSARY)
+47 ;
+48 ; PTIEN Patient IEN
+49 ;
+50 ; Return Values:
+51 ; <0 Error code
+52 ; 0 Ok
+53 ;
UPDPTDEM(PTIEN) ;
+1 NEW CF,DOD,IENS,RC,RORMSG,RORPAT
+2 SET IENS=PTIEN_","
SET CF=0
+3 ;--- Try to lock the record of the ROR PATIENT file
+4 LOCK +^RORDATA(798.4,PTIEN):3
+5 IF '$TEST
QUIT $$ERROR^RORERR(-11,,,PTIEN,"file #798.4")
+6 Begin DoDot:1
+7 ;--- Compare demographic data
+8 SET RC=$$PATDATA^RORUPD52(IENS,.RORPAT,IENS,.DOD)
if RC<0
QUIT
+9 if RC
SET CF=1
+10 ;--- Mark registry records of the patient
+11 IF CF
SET RC=$$MARKREGS(PTIEN,$GET(DOD))
if RC<0
QUIT
+12 ;--- Update demographic data
+13 IF CF
IF $DATA(RORPAT)>1
SET RC=0
Begin DoDot:2
+14 DO FILE^DIE(,"RORPAT","RORMSG")
if '$GET(DIERR)
QUIT
+15 SET RC=$$DBS^RORERR("RORMSG",-9,,PTIEN,798.4)
End DoDot:2
if RC<0
QUIT
End DoDot:1
+16 ;
+17 LOCK -^RORDATA(798.4,PTIEN)
+18 QUIT 0
+19 ;
+20 ;***** UPDATES RECORD COUNTERS IN THE 'ROR REGISTRY PARAMETERS' FILE
+21 ;
+22 ; .CNT( Reference to a local array containg registry
+23 ; record counters
+24 ; Registry#,
+25 ; 0) Number of confirmed records
+26 ; 4) Number of pending records
+27 ;
UPDRCNT(CNT) ;
+1 NEW IENS,RC,REGIEN,RORFDA,RORMSG
+2 SET REGIEN=0
+3 FOR
SET REGIEN=$ORDER(CNT(REGIEN))
if REGIEN=""
QUIT
Begin DoDot:1
+4 SET IENS=REGIEN_","
+5 SET RORFDA(798.1,IENS,19.1)=$GET(CNT(REGIEN,0))
+6 SET RORFDA(798.1,IENS,19.2)=$GET(CNT(REGIEN,4))
+7 DO FILE^DIE("K","RORFDA","RORMSG")
+8 IF $GET(DIERR)
Begin DoDot:2
+9 SET RC=$$DBS^RORERR("RORMSG",-9,,798.1,IENS)
End DoDot:2
QUIT
End DoDot:1
+10 QUIT
