source: WorldVistAEHR/trunk/r/PATIENT_REPRESENTATIVE-QAC/QACI2A.m@ 648

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

initial load of WorldVistAEHR
File size: 4.4 KB
RevLine 
[613]1QACI2A ; OAKOIFO/TKW - DATA MIGRATION - BUILD LEGACY DATA TO BE MIGRATED (CONT.) ;10/26/06 16:42
2 ;;2.0;Patient Representative;**19**;07/25/1995;Build 55
3PARVISN(PARENT,VISNNAME) ; Get Parent Station Number and VISN Name for a Station
4 N I,QACPAR
5 ; Get parent institution IEN from QAC SITE PARAMETERS file entry
6 S PARENT=$P($G(^QA(740,1,0)),"^"),VISNNAME=""
7 Q:'PARENT
8 ; Retrieve VISN name
9 D PARENT^XUAF4("QACPAR","`"_PARENT,1)
10 S I=$O(QACPAR("P",0)) I 'I S PARENT="" Q
11 S VISNNAME=$P(QACPAR("P",I),"^")
12 ; Get station number for parent station
13 S PARENT=$$STA^XUAF4(PARENT) S:PARENT="" VISNNAME=""
14 Q
15 ;
16ASK(FLAG) ; Question Confirming that User want to run this option
17 W !!,"This option builds temporary globals used to migrate all legacy data",!,"from the old Patient Representative system to the new Patient Advocate",!,"Tracking System (PATS).",!
18 ;I $G(FLAG)="X" D
19 ;. W !,"** This is the option to completely restart the migration process . **"
20 ;. W !,"If data was migrated in error, the PATS Production Database Manager",!,"should delete the data from PATS prior to running this option.",!
21 ;. Q
22 N DIR S DIR(0)="YO",DIR("A")="Are you sure",DIR("B")="YES"
23 S DIR("?",1)="This option reads through all of the ROCs. ROCs that have already been migrated"
24 S DIR("?",2)="to PATS will not be moved to the staging area again. ROCs are checked for"
25 S DIR("?",3)="data errors. Any ROCs with errors will not be moved to the staging area, and"
26 S DIR("?",4)="will be displayed on an error report at the end of the process."
27 S DIR("?",5)=""
28 S DIR("?",6)="Once ROCs have been moved to the staging area, they are ready to be migrated"
29 S DIR("?")="into PATS."
30 D ^DIR
31 Q Y
32 ;
33CEMOCTS ; Build mapping lists for contacting_entity, method_of_contact, treatment_status.
34 S MOC("P")=1,MOC("W")=2,MOC("V")=2,MOC("I")=3,MOC("L")=4,MOC("S")=5
35 Q:QACI0
36 S CE("PA")=1,CE("RE")=2,CE("FR")=3,CE("CO")=4,CE("VH")=5,CE("VO")=6,CE("AT")=7,CE("DI")=8,CE("ST")=9,CE("OT")=10
37 S TS("I")=6,TS("O")=7,TS("D")=8,TS("N")=9,TS("L")=10,TS("E")=11,TS("H")=12
38 Q
39 ;
40BLDISS ; Build a list of migrated National Issue Codes.
41 K ^XTMP("QACMIGR","ISS","D")
42 ; Count of national issue codes to migrate=59
43 S ^XTMP("QACMIGR","ISS","D")=59
44 N I
45 F I=1:1 S X=$P($T(LIST+I),";",3) Q:X="" S ^XTMP("QACMIGR","ISS","D",X)=""
46 Q
47 ;
48BLDCC(STATION,PATSCNT) ; Build list of all Congressional Contacts to migrate
49 N CCIEN,CCCNT,CC0,X,CCDNM
50 S CCCNT=0
51 F CCIEN=0:0 S CCIEN=$O(^QA(745.4,CCIEN)) Q:'CCIEN S CC0=$G(^(CCIEN,0)) D
52 . S CCNAME=$P(CC0,"^")
53 . Q:$D(^XTMP("QACMIGR","CC","D",CCIEN))
54 . S CCDNM=$E(CCNAME,1,20) S:$L(CCNAME)>20 CCDNM=CCDNM_"..."
55 . I $$TXTERR^QACI2C(CCNAME,60,0,1) D Q
56 .. D ERREF^QACI2C("CC",CCIEN,CCDNM_" - Office or Person Name invalid") Q
57 . S X=$P(CC0,"^",2) I X]"",X'=1,X'=0 D Q
58 .. D ERREF^QACI2C("CC",CCIEN,CCDNM_" - 'Inactive' flag is invalid") Q
59 . S ^XTMP("QACMIGR","CC","U",CCIEN)=CCIEN_"^"_STATION_"^"_CCNAME_"^"_X
60 . S CCCNT=CCCNT+1 Q
61 S PATSCNT("CC")=CCCNT
62 Q
63 ;
64BLDFSOS(FSOSIEN,FSOSNAME,QACI0,PATSCNT) ; Check for errors, build data for a single Facility Service or Section
65 Q:$D(^XTMP("QACMIGR","FSOS","E",FSOSIEN))
66 Q:$D(^XTMP("QACMIGR","FSOS","U",FSOSIEN))
67 I $$TXTERR^QACI2C(FSOSNAME,50,0,1) D Q
68 . N Y S Y=$L(FSOSNAME)
69 . S FSOSNAME=$E(FSOSNAME,1,30) I Y>30 S FSOSNAME=FSOSNAME_"..."
70 . D ERREF^QACI2C("FSOS",FSOSIEN,FSOSNAME_" - Name invalid") Q
71 ; Quit if called from ^QACI0 to just print the error report
72 Q:QACI0
73 ; Quite if fsos has already migrated
74 Q:$D(^XTMP("QACMIGR","FSOS","D",FSOSIEN))
75 S ^XTMP("QACMIGR","FSOS","U",FSOSIEN)=FSOSIEN_"^"_FSOSNAME
76 S PATSCNT("FSOS")=PATSCNT("FSOS")+1
77 Q
78 ;
79ERROC(OLDROC,MSG) ; Record an error on a ROC
80 Q:MSG=""
81 N ERRCNT S ERRCNT=$O(^XTMP("QACMIGR","ROC","E",OLDROC_" ","A"),-1)+1
82 S ^XTMP("QACMIGR","ROC","E",OLDROC_" ",ERRCNT)=MSG
83 I ERRCNT=1 D
84 . N I S I=$O(^QA(745.1,"B",OLDROC,0)) Q:'I
85 . S X=$P($G(^QA(745.1,I,0)),"^",6) Q:'X
86 . S X=$P($G(^VA(200,X,0)),"^") Q:X=""
87 . S $P(^XTMP("QACMIGR","ROC","E",OLDROC_" ",ERRCNT),"^",2)=X Q
88 Q
89 ;
90LIST ;; List of valid national issue codes
91 ;;AC01
92 ;;AC02
93 ;;AC03
94 ;;AC04
95 ;;AC05
96 ;;AC06
97 ;;AC07
98 ;;AC08
99 ;;AC09
100 ;;AC10
101 ;;AC11
102 ;;AC12
103 ;;CO01
104 ;;CO02
105 ;;CO03
106 ;;CO04
107 ;;CP01
108 ;;ED01
109 ;;ED02
110 ;;EM01
111 ;;EM02
112 ;;EM03
113 ;;EV01
114 ;;EV02
115 ;;EV03
116 ;;FI01
117 ;;IF01
118 ;;IF02
119 ;;IF04
120 ;;IF05
121 ;;IF06
122 ;;IF07
123 ;;IF08
124 ;;IF09
125 ;;IF10
126 ;;LL01
127 ;;LL02
128 ;;LL03
129 ;;LL04
130 ;;OP01
131 ;;OP02
132 ;;PC01
133 ;;PC02
134 ;;PR01
135 ;;PR02
136 ;;PR03
137 ;;PR04
138 ;;RE01
139 ;;RG01
140 ;;RG02
141 ;;RG03
142 ;;RI01
143 ;;RI02
144 ;;RI03
145 ;;RI04
146 ;;RI05
147 ;;SC01
148 ;;SC02
149 ;;TR01
150 ;;
Note: See TracBrowser for help on using the repository browser.