RORUPD52 ;HCIOFO/SG - UPDATE PATIENT'S DEMOGRAPHIC DATA (2) ; 12/12/05 9:19am
;;1.5;CLINICAL CASE REGISTRIES;**30**;Feb 17, 2006;Build 37
;
; This routine uses the following IAs:
;
; #174 RATED DISBAILITIES (VA) multiple (controlled)
; #2701 $$GETICN^MPIF001 Gets ICN
; #4807 RDIS^DGRPDB (supported)
; #10061 6^VADPT
;
;ROR*1.5*30 OCT 2016 M FERRARESE Changing the dispay for "Sex" to "Birth Sex"
;
Q
;
;***** LOAD DEMOGRAPHIC DATA FROM THE 'PATIENT' FILE
;
; DFN Internal Entry Number in the PATIENT file
;
; .RES Reference to a buffer for the data
;
; RES(1, Demographic and elegibility data
; ^1: SSN .09
; ^2: Date of Birth .03
; ^3: Birth Sex .02
; ^4: Date of Death .351
; ^5: Period of Service .323
; ^6: Service Connected? .301
; ^7: Service Connected Percentage .302
; ^8: ZIP+4 .1112
; ^9: ICN (with the checksum) 991.*
; "FL") List of field numbers separated by the ";"
;
; RES(2) Race and ethnicity data
; Race^Method^...^Ethnicity^Method^...
;
; Return Values:
; <0 Error code
; 0 Ok
;
LOADDM(DFN,RES) ;
N I,J,VA,VADM,VAEL,VAHOW,VAPA,VAROOT
S RES(1,"FL")=".09;.03;.02;.351;.323;.301;.302;.1112;991"
D 6^VADPT F I=1,2 S RES(I)=""
;--- Demographic and eligibility fields
F I=2,3,5,6 S RES(1)=RES(1)_U_$P($G(VADM(I)),U)
S $E(RES(1),1)="" ; Remove the first "^"
S I=$G(VAEL(3))
S RES(1)=RES(1)_U_$P($G(VAEL(2)),U)_U_$S(I:"Y",1:"N")_U_$P(I,U,2)
S I=$$GETICN^MPIF001(DFN)
S RES(1)=RES(1)_U_$P($G(VAPA(6)),U,2)_U_$S(I'<0:I,1:"")
;--- Race & Ethnicity
F I=11,12 S J="" D
. F S J=$O(VADM(I,J)) Q:J="" D
. . S RES(2)=RES(2)_U_$P(VADM(I,J),U)_U_$P($G(VADM(I,J,1)),U)
S $E(RES(2),1)="" ; Remove the first "^"
Q 0
;
;***** LOAD RATED DISABILITIES FROM THE 'PATIENT' FILE
;
; DFN Internal Entry Number in the PATIENT file
;
; .RES Reference to a buffer for the data
;
; RES(3) Rated disabilities data
; Rated Disability^Disability %^Service Connected^...
;
; Return Values:
; <0 Error code
; 0 Ok
;
LOADRD(DFN,RES) ;
N I,RC,RORBUF
S I=0
F S I=$O(^DPT(DFN,.372,I)) Q:I'>0 D
. S RORBUF(I)=$P($G(^DPT(DFN,.372,I,0)),U,1,3)
S RES(3)=$$CRC32^RORBIN("RORBUF")
Q 0
; Use this code to load disabilities when the API is fixed.
;S RC=$$RDIS^DGRPDB(DFN,.RORBUF)
;D:'RC ERROR^RORERR(-57,,,DFN,RC,"$$RDIS^DGRPDB")
;
;***** GETS AND PREPARES PATIENT'S DATA
;
; PATIENS Patient IENS in the PATIENT file
; .RORPAT Reference to the FDA for field values
; RORIENS IENS of the record in the ROR PATIENT file
; [.DOD] Date of death is returned via this parameter
;
; Return Values:
; <0 Error code
; 0 Patient data has not been changed
; >0 Data has been changed
;
PATDATA(PATIENS,RORPAT,RORIENS,DOD) ;
N BUF,DIFCNT,N1,NODE,RC,RORDFN
S:PATIENS'["," PATIENS=PATIENS_","
S:RORIENS'["," RORIENS=RORIENS_","
S RORDFN=$S(RORIENS?1.N1",":+RORIENS,1:-1)
S DOD="",(DIFCNT,RC)=0
;--- Load demographic data from the PATIENT file
S RC=$$LOADDM(+PATIENS,.NODE) Q:RC<0 RC
S DOD=$P(NODE(1),U,4),N1=$L(NODE(1,"FL"),";")
;--- Demographic and eligibility fields
S BUF=$P($G(^RORDATA(798.4,RORDFN,1)),U,1,N1)
I NODE(1)'=BUF D
. N CF,FLD,I
. F I=1:1:N1 S FLD=+$P(NODE(1,"FL"),";",I) D:FLD>0
. . K RORPAT(798.4,RORIENS,FLD)
. . ;--- Update the field if necessary
. . S OLDVAL=$P(BUF,U,I) Q:$P(NODE(1),U,I)=OLDVAL
. . S RORPAT(798.4,RORIENS,FLD)=$P(NODE(1),U,I),CF=1
. . ;--- Save previous values of the special fields
. . I FLD=.09 D Q
. . . S RORPAT(798.4,RORIENS,10.1)=OLDVAL ; Old SSN
. . I FLD=991.01 D Q
. . . S RORPAT(798.4,RORIENS,10.2)=OLDVAL ; Old ICN
. I $G(CF) S DIFCNT=DIFCNT+1 Q
. S $P(^RORDATA(798.4,RORDFN,1),U,N1)=$P(BUF,U,N1)
;--- Race & Ethnicity
I NODE(2)'=$G(^RORDATA(798.4,RORDFN,2)) D
. S DIFCNT=DIFCNT+1,RORPAT(798.4,RORIENS,2)=NODE(2)
K NODE
;--- Rated disabilities
S RC=$$LOADRD(+PATIENS,.NODE) Q:RC<0 RC
I NODE(3)'=$G(^RORDATA(798.4,RORDFN,3)) D
. S DIFCNT=DIFCNT+1,RORPAT(798.4,RORIENS,.3721)=NODE(3)
Q $S(RC<0:RC,1:DIFCNT)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORUPD52 4581 printed Apr 09, 2024@20:49:15 Page 2
RORUPD52 ;HCIOFO/SG - UPDATE PATIENT'S DEMOGRAPHIC DATA (2) ; 12/12/05 9:19am
+1 ;;1.5;CLINICAL CASE REGISTRIES;**30**;Feb 17, 2006;Build 37
+2 ;
+3 ; This routine uses the following IAs:
+4 ;
+5 ; #174 RATED DISBAILITIES (VA) multiple (controlled)
+6 ; #2701 $$GETICN^MPIF001 Gets ICN
+7 ; #4807 RDIS^DGRPDB (supported)
+8 ; #10061 6^VADPT
+9 ;
+10 ;ROR*1.5*30 OCT 2016 M FERRARESE Changing the dispay for "Sex" to "Birth Sex"
+11 ;
+12 QUIT
+13 ;
+14 ;***** LOAD DEMOGRAPHIC DATA FROM THE 'PATIENT' FILE
+15 ;
+16 ; DFN Internal Entry Number in the PATIENT file
+17 ;
+18 ; .RES Reference to a buffer for the data
+19 ;
+20 ; RES(1, Demographic and elegibility data
+21 ; ^1: SSN .09
+22 ; ^2: Date of Birth .03
+23 ; ^3: Birth Sex .02
+24 ; ^4: Date of Death .351
+25 ; ^5: Period of Service .323
+26 ; ^6: Service Connected? .301
+27 ; ^7: Service Connected Percentage .302
+28 ; ^8: ZIP+4 .1112
+29 ; ^9: ICN (with the checksum) 991.*
+30 ; "FL") List of field numbers separated by the ";"
+31 ;
+32 ; RES(2) Race and ethnicity data
+33 ; Race^Method^...^Ethnicity^Method^...
+34 ;
+35 ; Return Values:
+36 ; <0 Error code
+37 ; 0 Ok
+38 ;
LOADDM(DFN,RES) ;
+1 NEW I,J,VA,VADM,VAEL,VAHOW,VAPA,VAROOT
+2 SET RES(1,"FL")=".09;.03;.02;.351;.323;.301;.302;.1112;991"
+3 DO 6^VADPT
FOR I=1,2
SET RES(I)=""
+4 ;--- Demographic and eligibility fields
+5 FOR I=2,3,5,6
SET RES(1)=RES(1)_U_$PIECE($GET(VADM(I)),U)
+6 ; Remove the first "^"
SET $EXTRACT(RES(1),1)=""
+7 SET I=$GET(VAEL(3))
+8 SET RES(1)=RES(1)_U_$PIECE($GET(VAEL(2)),U)_U_$SELECT(I:"Y",1:"N")_U_$PIECE(I,U,2)
+9 SET I=$$GETICN^MPIF001(DFN)
+10 SET RES(1)=RES(1)_U_$PIECE($GET(VAPA(6)),U,2)_U_$SELECT(I'<0:I,1:"")
+11 ;--- Race & Ethnicity
+12 FOR I=11,12
SET J=""
Begin DoDot:1
+13 FOR
SET J=$ORDER(VADM(I,J))
if J=""
QUIT
Begin DoDot:2
+14 SET RES(2)=RES(2)_U_$PIECE(VADM(I,J),U)_U_$PIECE($GET(VADM(I,J,1)),U)
End DoDot:2
End DoDot:1
+15 ; Remove the first "^"
SET $EXTRACT(RES(2),1)=""
+16 QUIT 0
+17 ;
+18 ;***** LOAD RATED DISABILITIES FROM THE 'PATIENT' FILE
+19 ;
+20 ; DFN Internal Entry Number in the PATIENT file
+21 ;
+22 ; .RES Reference to a buffer for the data
+23 ;
+24 ; RES(3) Rated disabilities data
+25 ; Rated Disability^Disability %^Service Connected^...
+26 ;
+27 ; Return Values:
+28 ; <0 Error code
+29 ; 0 Ok
+30 ;
LOADRD(DFN,RES) ;
+1 NEW I,RC,RORBUF
+2 SET I=0
+3 FOR
SET I=$ORDER(^DPT(DFN,.372,I))
if I'>0
QUIT
Begin DoDot:1
+4 SET RORBUF(I)=$PIECE($GET(^DPT(DFN,.372,I,0)),U,1,3)
End DoDot:1
+5 SET RES(3)=$$CRC32^RORBIN("RORBUF")
+6 QUIT 0
+7 ; Use this code to load disabilities when the API is fixed.
+8 ;S RC=$$RDIS^DGRPDB(DFN,.RORBUF)
+9 ;D:'RC ERROR^RORERR(-57,,,DFN,RC,"$$RDIS^DGRPDB")
+10 ;
+11 ;***** GETS AND PREPARES PATIENT'S DATA
+12 ;
+13 ; PATIENS Patient IENS in the PATIENT file
+14 ; .RORPAT Reference to the FDA for field values
+15 ; RORIENS IENS of the record in the ROR PATIENT file
+16 ; [.DOD] Date of death is returned via this parameter
+17 ;
+18 ; Return Values:
+19 ; <0 Error code
+20 ; 0 Patient data has not been changed
+21 ; >0 Data has been changed
+22 ;
PATDATA(PATIENS,RORPAT,RORIENS,DOD) ;
+1 NEW BUF,DIFCNT,N1,NODE,RC,RORDFN
+2 if PATIENS'[","
SET PATIENS=PATIENS_","
+3 if RORIENS'[","
SET RORIENS=RORIENS_","
+4 SET RORDFN=$SELECT(RORIENS?1.N1",":+RORIENS,1:-1)
+5 SET DOD=""
SET (DIFCNT,RC)=0
+6 ;--- Load demographic data from the PATIENT file
+7 SET RC=$$LOADDM(+PATIENS,.NODE)
if RC<0
QUIT RC
+8 SET DOD=$PIECE(NODE(1),U,4)
SET N1=$LENGTH(NODE(1,"FL"),";")
+9 ;--- Demographic and eligibility fields
+10 SET BUF=$PIECE($GET(^RORDATA(798.4,RORDFN,1)),U,1,N1)
+11 IF NODE(1)'=BUF
Begin DoDot:1
+12 NEW CF,FLD,I
+13 FOR I=1:1:N1
SET FLD=+$PIECE(NODE(1,"FL"),";",I)
if FLD>0
Begin DoDot:2
+14 KILL RORPAT(798.4,RORIENS,FLD)
+15 ;--- Update the field if necessary
+16 SET OLDVAL=$PIECE(BUF,U,I)
if $PIECE(NODE(1),U,I)=OLDVAL
QUIT
+17 SET RORPAT(798.4,RORIENS,FLD)=$PIECE(NODE(1),U,I)
SET CF=1
+18 ;--- Save previous values of the special fields
+19 IF FLD=.09
Begin DoDot:3
+20 ; Old SSN
SET RORPAT(798.4,RORIENS,10.1)=OLDVAL
End DoDot:3
QUIT
+21 IF FLD=991.01
Begin DoDot:3
+22 ; Old ICN
SET RORPAT(798.4,RORIENS,10.2)=OLDVAL
End DoDot:3
QUIT
End DoDot:2
+23 IF $GET(CF)
SET DIFCNT=DIFCNT+1
QUIT
+24 SET $PIECE(^RORDATA(798.4,RORDFN,1),U,N1)=$PIECE(BUF,U,N1)
End DoDot:1
+25 ;--- Race & Ethnicity
+26 IF NODE(2)'=$GET(^RORDATA(798.4,RORDFN,2))
Begin DoDot:1
+27 SET DIFCNT=DIFCNT+1
SET RORPAT(798.4,RORIENS,2)=NODE(2)
End DoDot:1
+28 KILL NODE
+29 ;--- Rated disabilities
+30 SET RC=$$LOADRD(+PATIENS,.NODE)
if RC<0
QUIT RC
+31 IF NODE(3)'=$GET(^RORDATA(798.4,RORDFN,3))
Begin DoDot:1
+32 SET DIFCNT=DIFCNT+1
SET RORPAT(798.4,RORIENS,.3721)=NODE(3)
End DoDot:1
+33 QUIT $SELECT(RC<0:RC,1:DIFCNT)
