source: WorldVistAEHR/trunk/r/CLINICAL_CASE_REGISTRIES-ROR/RORUPD52.m@ 1351

Last change on this file since 1351 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.2 KB
Line 
1RORUPD52 ;HCIOFO/SG - UPDATE PATIENT'S DEMOGRAPHIC DATA (2) ; 12/12/05 9:19am
2 ;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
3 ;
4 ; This routine uses the following IAs:
5 ;
6 ; #174 RATED DISBAILITIES (VA) multiple (controlled)
7 ; #2701 $$GETICN^MPIF001 Gets ICN
8 ; #4807 RDIS^DGRPDB (supported)
9 ; #10061 6^VADPT
10 ;
11 Q
12 ;
13 ;***** LOAD DEMOGRAPHIC DATA FROM THE 'PATIENT' FILE
14 ;
15 ; DFN Internal Entry Number in the PATIENT file
16 ;
17 ; .RES Reference to a buffer for the data
18 ;
19 ; RES(1, Demographic and elegibility data
20 ; ^1: SSN .09
21 ; ^2: Date of Birth .03
22 ; ^3: Sex .02
23 ; ^4: Date of Death .351
24 ; ^5: Period of Service .323
25 ; ^6: Service Connected? .301
26 ; ^7: Service Connected Percentage .302
27 ; ^8: ZIP+4 .1112
28 ; ^9: ICN (with the checksum) 991.*
29 ; "FL") List of field numbers separated by the ";"
30 ;
31 ; RES(2) Race and ethnicity data
32 ; Race^Method^...^Ethnicity^Method^...
33 ;
34 ; Return Values:
35 ; <0 Error code
36 ; 0 Ok
37 ;
38LOADDM(DFN,RES) ;
39 N I,J,VA,VADM,VAEL,VAHOW,VAPA,VAROOT
40 S RES(1,"FL")=".09;.03;.02;.351;.323;.301;.302;.1112;991"
41 D 6^VADPT F I=1,2 S RES(I)=""
42 ;--- Demographic and eligibility fields
43 F I=2,3,5,6 S RES(1)=RES(1)_U_$P($G(VADM(I)),U)
44 S $E(RES(1),1)="" ; Remove the first "^"
45 S I=$G(VAEL(3))
46 S RES(1)=RES(1)_U_$P($G(VAEL(2)),U)_U_$S(I:"Y",1:"N")_U_$P(I,U,2)
47 S I=$$GETICN^MPIF001(DFN)
48 S RES(1)=RES(1)_U_$P($G(VAPA(6)),U,2)_U_$S(I'<0:I,1:"")
49 ;--- Race & Ethnicity
50 F I=11,12 S J="" D
51 . F S J=$O(VADM(I,J)) Q:J="" D
52 . . S RES(2)=RES(2)_U_$P(VADM(I,J),U)_U_$P($G(VADM(I,J,1)),U)
53 S $E(RES(2),1)="" ; Remove the first "^"
54 Q 0
55 ;
56 ;***** LOAD RATED DISABILITIES FROM THE 'PATIENT' FILE
57 ;
58 ; DFN Internal Entry Number in the PATIENT file
59 ;
60 ; .RES Reference to a buffer for the data
61 ;
62 ; RES(3) Rated disabilities data
63 ; Rated Disability^Disability %^Service Connected^...
64 ;
65 ; Return Values:
66 ; <0 Error code
67 ; 0 Ok
68 ;
69LOADRD(DFN,RES) ;
70 N I,RC,RORBUF
71 S I=0
72 F S I=$O(^DPT(DFN,.372,I)) Q:I'>0 D
73 . S RORBUF(I)=$P($G(^DPT(DFN,.372,I,0)),U,1,3)
74 S RES(3)=$$CRC32^RORBIN("RORBUF")
75 Q 0
76 ; Use this code to load disabilities when the API is fixed.
77 ;S RC=$$RDIS^DGRPDB(DFN,.RORBUF)
78 ;D:'RC ERROR^RORERR(-57,,,DFN,RC,"$$RDIS^DGRPDB")
79 ;
80 ;***** GETS AND PREPARES PATIENT'S DATA
81 ;
82 ; PATIENS Patient IENS in the PATIENT file
83 ; .RORPAT Reference to the FDA for field values
84 ; RORIENS IENS of the record in the ROR PATIENT file
85 ; [.DOD] Date of death is returned via this parameter
86 ;
87 ; Return Values:
88 ; <0 Error code
89 ; 0 Patient data has not been changed
90 ; >0 Data has been changed
91 ;
92PATDATA(PATIENS,RORPAT,RORIENS,DOD) ;
93 N BUF,DIFCNT,N1,NODE,RC,RORDFN
94 S:PATIENS'["," PATIENS=PATIENS_","
95 S:RORIENS'["," RORIENS=RORIENS_","
96 S RORDFN=$S(RORIENS?1.N1",":+RORIENS,1:-1)
97 S DOD="",(DIFCNT,RC)=0
98 ;--- Load demographic data from the PATIENT file
99 S RC=$$LOADDM(+PATIENS,.NODE) Q:RC<0 RC
100 S DOD=$P(NODE(1),U,4),N1=$L(NODE(1,"FL"),";")
101 ;--- Demographic and eligibility fields
102 S BUF=$P($G(^RORDATA(798.4,RORDFN,1)),U,1,N1)
103 I NODE(1)'=BUF D
104 . N CF,FLD,I
105 . F I=1:1:N1 S FLD=+$P(NODE(1,"FL"),";",I) D:FLD>0
106 . . K RORPAT(798.4,RORIENS,FLD)
107 . . ;--- Update the field if necessary
108 . . S OLDVAL=$P(BUF,U,I) Q:$P(NODE(1),U,I)=OLDVAL
109 . . S RORPAT(798.4,RORIENS,FLD)=$P(NODE(1),U,I),CF=1
110 . . ;--- Save previous values of the special fields
111 . . I FLD=.09 D Q
112 . . . S RORPAT(798.4,RORIENS,10.1)=OLDVAL ; Old SSN
113 . . I FLD=991.01 D Q
114 . . . S RORPAT(798.4,RORIENS,10.2)=OLDVAL ; Old ICN
115 . I $G(CF) S DIFCNT=DIFCNT+1 Q
116 . S $P(^RORDATA(798.4,RORDFN,1),U,N1)=$P(BUF,U,N1)
117 ;--- Race & Ethnicity
118 I NODE(2)'=$G(^RORDATA(798.4,RORDFN,2)) D
119 . S DIFCNT=DIFCNT+1,RORPAT(798.4,RORIENS,2)=NODE(2)
120 K NODE
121 ;--- Rated disabilities
122 S RC=$$LOADRD(+PATIENS,.NODE) Q:RC<0 RC
123 I NODE(3)'=$G(^RORDATA(798.4,RORDFN,3)) D
124 . S DIFCNT=DIFCNT+1,RORPAT(798.4,RORIENS,.3721)=NODE(3)
125 Q $S(RC<0:RC,1:DIFCNT)
Note: See TracBrowser for help on using the repository browser.