source: FOIAVistA/trunk/r/PATIENT_REPRESENTATIVE-QAC/QACI20.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 7.3 KB
Line 
1QACI20 ; OAKOIFO/TKW - DATA MIGRATION - BUILD SUPPORTING TABLE AND ROC DATA TO MIGRATE (CONT.) ;01/12/2007 11:48
2 ;;2.0;Patient Representative;**19**;07/25/1995;Build 55
3 ;
4EN ; Read through ROCs, check for errors and if QACI0=0, move data to staging area.
5 F ROCIEN=0:0 S ROCIEN=$O(^QA(745.1,ROCIEN)) Q:'ROCIEN S ROC0=$G(^(ROCIEN,0)) D
6 . S DOTCNT=DOTCNT+1 I DOTCNT=200 W "." S DOTCNT=0
7 . S X="" F I=2:1:16 S X=X_$P(ROC0,"^",I)
8 . S OLDROC=$P(ROC0,"^")
9 . ; If ROC has no ROC number, or nothing but a ROC number, delete it.
10 . I X=""!(OLDROC="") S DIK="^QA(745.1,",DA=ROCIEN D ^DIK Q
11 . ; Convert ROC Number to PATS format
12 . S ROCNO=$$CONVROC^QACI2C(OLDROC)
13 . I ROCNO'?3N.E1"."9N D ERROC^QACI2A(OLDROC,"ROC number is not correctly formatted") Q
14 . ; Quit if ROC has already been migrated.
15 . I $D(^XTMP("QACMIGR","ROC","D",ROCNO)) S X=^(ROCNO) D Q
16 .. I X="" S ^XTMP("QACMIGR","ROC","D",ROCNO)=ROCIEN Q
17 .. I X'=ROCIEN D ERROC^QACI2A(OLDROC_" IEN: "_ROCIEN," is a duplicate ROC number")
18 .. Q
19 . ; Generate an error for duplicate ROC numbers
20 . I $D(^XTMP("QACMIGR","ROC","U",ROCNO_" "))!($D(^XTMP("QACMIGR","ROC","E",OLDROC_" "))) D Q
21 .. D ERROC^QACI2A(OLDROC_" IEN: "_ROCIEN," is a duplicate ROC number") Q
22 . ; Extract date of contact, convert to 'Oracle friendly' format
23 . I $P(ROC0,"^",2)="" D ERROC^QACI2A(OLDROC,"DATE OF CONTACT is missing") Q
24 . D DT^DILF("X",$P(ROC0,"^",2),.CONDATE)
25 . I CONDATE>0 S CONDATE=$$FMTE^XLFDT(CONDATE,5)
26 . I CONDATE'?1.2N1"/"1.2N1"/"4N D ERROC^QACI2A(OLDROC,"DATE OF CONTACT is invalid")
27 . ; Kill ROC from list of ROCs whose data was changed during migration
28 . ; and initialize variables indicating ROC was changed
29 . D:'QACI0
30 .. K ^XTMP("QACMIGR","ROC","C",OLDROC_" ")
31 .. S (EDITEBY,EDITIBY,EDITDIV,EDITITXT,EDITRTXT)=0 Q
32 . S ROC2=$G(^QA(745.1,ROCIEN,2)),ROC7=$G(^(7))
33 . ;
34 . ; Get station number
35 . S STATION=$P(ROC0,"^",16) I STATION]"" D Q:STATION=""
36 .. I '$D(QACDIV(STATION)) D ERROC^QACI2A(OLDROC,"DIVISION pointer "_+STATION_" not in MEDICAL CENTER DIVISION file") Q
37 .. S STATION=$$STA^XUAF4(STATION)
38 .. I STATION="" D ERROC^QACI2A(OLDROC,"DIVISION pointer "_+STATION_" is invalid or has no Station Number") Q
39 .. I '$D(^XTMP("QACMIGR","STDINSTITUTION",STATION)) D ERROC^QACI2A(OLDROC,"DIVISION "_STATION_" is not a valid national station")
40 .. Q
41 . E D
42 .. S STATION=$P(ROC0,"."),EDITDIV=1
43 .. I '$$LKUP^XUAF4(STATION) D ERROC^QACI2A(OLDROC,"STATION number part of ROC number is invalid.") Q
44 .. I '$D(^XTMP("QACMIGR","STDINSTITUTION",STATION)) D ERROC^QACI2A(OLDROC,"DIVISION "_STATION_" is not a valid national station")
45 .. Q
46 . ;
47 . ; Get Patient IEN
48 . S DFN=$P(ROC0,"^",3) I DFN]"" D
49 .. I 'DFN!('$D(^DPT(+DFN))) D ERROC^QACI2A(OLDROC,"PATIENT pointer "_+DFN_" is invalid") Q
50 .. ; build data for pats_patient table
51 .. S PATSERR=0 D PTDATA^QACI2B(PARENT,DFN,QACI0,.PATSERR,.PATSCNT)
52 .. I PATSERR D ERROC^QACI2A(OLDROC,"PATIENT has invalid data--see ref data report") Q
53 . ;
54 . ;Extract and convert to Id value--contacting_entity, treatment_status
55 . I 'QACI0 D
56 .. S X=$P(ROC0,"^",10),CE=$S(X="":10,$G(CE(X)):CE(X),1:10)
57 .. S X=$P(ROC2,"^",2) D
58 ... I X]"",$G(TS(X)) S TS=TS(X) Q
59 ... S TS=$S(DFN="":5,1:4) Q
60 .. Q
61 . ;
62 . ; Get hospital location data
63 . S HL=$P(ROC0,"^",12)
64 . ;
65 . ; Get Pats User data
66 . S INFOBY=+$P(ROC0,"^",6),ENTBY=+$P(ROC0,"^",7)
67 . I 'ENTBY S ENTBY=INFOBY,EDITEBY=1
68 . I 'INFOBY S INFOBY=ENTBY,EDITIBY=1
69 . I 'INFOBY D ERROC^QACI2A(OLDROC,"INFO TAKEN BY and ENTERED BY are both NULL")
70 . D:INFOBY
71 .. I '$D(^VA(200,INFOBY,0)) D ERROC^QACI2A(OLDROC,"INFO TAKEN BY pointer "_+INFOBY_" is invalid") Q
72 .. ; build data for pats_user table
73 .. S PATSERR=0 D USERDATA^QACI2B(PARENT,INFOBY,"U",QACI0,.PATSERR,.PATSCNT)
74 .. I PATSERR D ERROC^QACI2A(OLDROC,"INFO TAKER has invalid data--see USER on ref data report") Q
75 . I ENTBY,ENTBY'=INFOBY D
76 .. I '$D(^VA(200,ENTBY,0)) D ERROC^QACI2A(OLDROC,"ENTERED BY pointer "_+ENTBY_" is invalid") Q
77 .. ; build data for pats_user table
78 .. S PATSERR=0 D USERDATA^QACI2B(PARENT,ENTBY,"U",QACI0,.PATSERR,.PATSCNT)
79 .. I PATSERR D ERROC^QACI2A(OLDROC,"ENTERED BY has invalid data--see USER on ref data report") Q
80 . ;
81 . ; If telephone no.is null but name of contact is not, set telephone toa single space.
82 . S PHONE=$P(ROC0,"^",9),PHDESC=$P(ROC0,"^",8)
83 . I PHONE]"",$$TXTERR^QACI2C(PHONE,30) D ERROC^QACI2A(OLDROC,"TELEPHONE NO. too long or contains control characters")
84 . I PHDESC]"",$$TXTERR^QACI2C(PHDESC,30) D ERROC^QACI2A(OLDROC,"NAME OF CONTACT too long or contains control characters")
85 . I PHDESC]"",PHONE="" S PHONE=" "
86 . ;
87 . ; Get resolution date
88 . S RESDATE=$P(ROC7,"^") I RESDATE]"" D
89 .. D DT^DILF("X",$P(ROC7,"^"),.RESDATE)
90 .. I RESDATE>0 S RESDATE=$$FMTE^XLFDT(RESDATE,5)
91 .. I RESDATE'?1.2N1"/"1.2N1"/"4N D ERROC^QACI2A(OLDROC,"DATE RESOLVED is invalid")
92 .. Q
93 . ;
94 . ; Get ROC Status
95 . S STATUS=$P(ROC7,"^",2) I STATUS'="O",STATUS'="C" D ERROC^QACI2A(OLDROC,"STATUS not set to either Open or Closed")
96 . ;
97 . ; Get Congressional Contact
98 . S CC=$P(ROC0,"^",13),CCNAME=""
99 . I CC]"" D
100 .. I '$D(^QA(745.4,+CC,0)) D ERROC^QACI2A(OLDROC,"CONGRESSIONAL CONTACT pointer "_+CC_" is invalid") Q
101 .. S CCNAME=$P($G(^QA(745.4,+CC,0)),"^") S:CCNAME="" CCNAME="** no name **"
102 .. I $D(^XTMP("QACMIGR","CC","E",+CC)) D ERROC^QACI2A(OLDROC,"CONGRESSIONAL CONTACT "_CCNAME_" invalid--see ref data report")
103 .. Q
104 . ;
105 . ; Get 'Is internal appeal?' flag
106 . S INTAPPL=$P(ROC2,"^",7),INTAPPL=$S(INTAPPL="Y":1,1:0)
107 . ;
108 . ; Get Eligibility Status and Category at time ROC was entered
109 . D ELIGCAT^QACI2B(.ELIGSTAT,.CATEGORY,ROC0)
110 . ;
111 . ; Get rollup status
112 . S RLUPSTAT=0 I $P($G(^QA(745.1,ROCIEN,7)),"^",6)=3 S RLUPSTAT=1
113 . ;
114 . ; Build Issue Text and Resolution Text into output global
115 . N RESERR
116 . D BLDTXT^QACI2C(ROCNO,ROCIEN,QACI0,.ROCCNT,.RESERR,.EDITITXT,.EDITRTXT)
117 . ;
118 . ; If not called from ^QACI0, Build data for report of fields changed for migration.
119 . I 'QACI0,(EDITEBY+EDITIBY+EDITDIV+EDITITXT+EDITRTXT)>0 D
120 .. Q:$D(^XTMP("QACMIGR","ROC","E",OLDROC_" "))
121 .. S ^XTMP("QACMIGR","ROC","C",OLDROC_" ")=EDITEBY_"^"_EDITIBY_"^"_EDITDIV_"^"_EDITITXT_"^"_EDITRTXT
122 .. Q
123 . ; Build main ROC data - if called from ^QACI0, just set node.
124 . I QACI0 S ^XTMP("QACMIGR","ROC","U",ROCNO_" ",1)=""
125 . E S ^XTMP("QACMIGR","ROC","U",ROCNO_" ",1)=ROCNO_"^MAIN^"_CONDATE_"^"_DFN_"^"_INFOBY_"^"_ENTBY_"^"_TS_"^"_CCNAME_"^"_STATUS_"^"_STATION_"^"_RESDATE_"^"_PHDESC_"^"_PHONE_"^"_CE_"^"_INTAPPL_"^"_ELIGSTAT_"^"_CATEGORY_"^"_RLUPSTAT_"^"
126 . ;
127 . ; Build Issue Code combinations into output global
128 . S ISSERR=$$ENISS^QACI2D(ROCIEN,ROCNO,OLDROC,QACI0,.ROCCNT,.RESERR,HL,PARENT,STATION,.PATSCNT)
129 . I ISSERR K ^XTMP("QACMIGR","ROC","U",ROCNO_" ")
130 . ; Build Methods of Contact into output global
131 . S (MOC,MOCSTR)=""
132 . S X=$P(ROC0,"^",11)
133 . I X]"" S MOC=$G(MOC(X)) I MOC="" D ERROC^QACI2A(OLDROC,"SOURCE OF CONTACT is invalid")
134 . I MOC]"" S MOCSTR=MOC_"^"
135 . F I=0:0 S I=$O(^QA(745.1,ROCIEN,12,I)) Q:'I S X=$P($G(^(I,0)),"^") D:X]""
136 .. S MOC=$G(MOC(X))
137 .. I MOC="" D ERROC^QACI2A(OLDROC,"SOURCE(S) OF CONTACT are invalid") Q
138 .. S MOCSTR=MOCSTR_MOC_"^" Q
139 . I MOCSTR]"" D
140 .. ; If called from ^QACI0, we don't need to save data
141 .. Q:QACI0
142 .. Q:$D(^XTMP("QACMIGR","ROC","E",OLDROC_" "))
143 .. S ROCCNT=ROCCNT+1
144 .. S ^XTMP("QACMIGR","ROC","U",ROCNO_" ",ROCCNT)=ROCNO_"^MOC^"_MOCSTR
145 .. Q
146 . I $D(^XTMP("QACMIGR","ROC","E",OLDROC_" ")) K ^XTMP("QACMIGR","ROC","U",ROCNO_" ") Q
147 . S PATSCNT("ROC")=PATSCNT("ROC")+1
148 . Q
149 Q
150 ;
151 ;
Note: See TracBrowser for help on using the repository browser.