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