source: WorldVistAEHR/trunk/r/WOMENS_HEALTH-WV/WVPRE.m@ 1006

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

initial load of WorldVistAEHR

File size: 4.0 KB
Line 
1WVPRE ;HCIOFO/FT-Pre-Installation Routine ;9/16/98 13:06
2 ;;1.0;WOMEN'S HEALTH;;Sep 30, 1998
3 ;
4 Q:'+$$VERSION^XPDUTL("BW") ;IHS WH not installed
5 Q:$D(^WV(790)) ;data transfer has been done already
6 D COPY
7 D NAME
8 D REPAIR
9 D FIELDS
10 D CREDIT
11 Q
12COPY ; Copy data from IHS files into VISTA files.
13 ; Does not delete IHS data.
14 D BMES^XPDUTL("Copying data from IHS files to VISTA Women's Health files.")
15 M ^WV(790)=^BWP
16 M ^WV(790.01)=^BWMGR
17 M ^WV(790.02)=^BWSITE
18 M ^WV(790.03)=^BWPR
19 M ^WV(790.04)=^BWPLOG
20 M ^WV(790.05)=^BWEDC
21 M ^WV(790.1)=^BWPCD
22 M ^WV(790.2)=^BWPN
23 M ^WV(790.31)=^BWDIAG
24 M ^WV(790.32)=^BWRADX
25 M ^WV(790.4)=^BWNOT
26 M ^WV(790.403)=^BWNOTT
27 M ^WV(790.404)=^BWNOTP
28 M ^WV(790.405)=^BWNOTO
29 M ^WV(790.5)=^BWCUR
30 M ^WV(790.51)=^BWMAMT
31 M ^WV(790.6)=^BWLET
32 M ^WV(790.71)=^BWSNAP
33 M ^WV(790.72)=^BWAGDF
34 Q
35NAME ; Change file name and number on zero node
36 S WVX=789.9999
37 F S WVX=$O(^WV(WVX)) Q:'WVX D
38 .S WVNODE=$G(^WV(WVX,0))
39 .S WVNAME=$P(WVNODE,U,1),WVNAME="WV"_$P(WVNAME,"BW",2)
40 .S $P(WVNODE,U,1)=WVNAME
41 .S WVNUMBER=$P(WVNODE,U,2),WVNUMBER="790"_$P(WVNUMBER,"9002086",2)
42 .S WVNUMBER=WVNUMBER_$S(WVNUMBER["s":"",1:"s")
43 .S $P(WVNODE,U,2)=WVNUMBER
44 .S ^WV(WVX,0)=WVNODE
45 .Q
46 K WVX,WVNAME,WVNODE,WVNUMBER
47 Q
48REPAIR ; Do data repair/clean up
49 D BMES^XPDUTL("Fixing data copied from IHS Women's Health files.")
50 ; Change NEW status in File 790.1 to OPEN. NEW no longer exists.
51 S WVIEN=0
52 F S WVIEN=$O(^WV(790.1,WVIEN)) Q:'WVIEN D
53 .Q:$P(^WV(790.1,WVIEN,0),U,14)'="n"
54 .S $P(^WV(790.1,WVIEN,0),U,14)="o"
55 .K ^WV(790.1,"S","n",WVIEN)
56 .Q
57 ; Change AGENCY value in File 790.02 to VA if not already VA
58 S WVIEN=0
59 F S WVIEN=$O(^WV(790.02,WVIEN)) Q:'WVIEN D
60 .Q:$P(^WV(790.02,WVIEN,0),U,15)="v"
61 .S $P(^WV(790.02,WVIEN,0),U,15)="v"
62 .Q
63 K WVIEN
64 Q
65FIELDS ; Set deleted fields values to ""
66 ; Set Date Inactive (File 790, #.24) if patient is dead.
67 ; Kill X-refs on deleted fields
68 ; ---> File 790, fld# .2 ("CDC")
69 ; ---> File 790.1, fld# .17 "ACDC")
70 S WVX=0 F S WVX=$O(^WV(790,WVX)) Q:WVX'>0 D
71 .S $P(^WV(790,WVX,0),U,20)=""
72 .Q:$P(^WV(790,WVX,0),U,24) ;Date Inactive exists
73 .S WVDOD=$P($G(^DPT(WVX,.35)),U,1) ;date of death
74 .Q:'WVDOD
75 .S WVDOD=WVDOD\1
76 .S $P(^WV(790,WVX,0),U,24)=WVDOD
77 .Q
78 K ^WV(790,"CDC") S WVX=0
79 F S WVX=$O(^WV(790.02,WVX)) Q:WVX'>0 D
80 .F WVY=9,11,12,13,14,16,17,20 S $P(^WV(790.02,WVX,0),U,WVY)=""
81 .F WVY=1,2,3,4,7,8,17:1:35,37,38 S $P(^WV(790.02,WVX,WVY),U,2)=""
82 S WVX=0 F S WVX=$O(^WV(790.1,WVX)) Q:WVX'>0 D
83 .F WVY=3,16,17 S $P(^WV(790.1,WVX,0),U,WVY)=""
84 .K ^WV(790.1,WVX,"PCC")
85 .S WVQUAD=$P($G(^WV(790.1,WVX,2)),U,16)
86 .K ^WV(790.1,WVX,2)
87 .S:WVQUAD]"" $P(^WV(790.1,WVX,2),U,16)=WVQUAD
88 .Q
89 K ^WV(790.1,"ACDC")
90 S WVX=0 F S WVX=$O(^WV(790.2,WVX)) Q:WVX'>0 D
91 .F WVY=12:1:17 S $P(^WV(790.2,WVX,0),U,WVY)=""
92 S WVX=0 F S WVX=$O(^WV(790.31,WVX)) Q:WVX'>0 D
93 .F WVY=24:1:27 S $P(^WV(790.31,WVX,0),U,WVY)=""
94 S WVX=0
95 F S WVX=$O(^WV(790.51,WVX)) Q:WVX'>0 D
96 .S $P(^WV(790.51,WVX,0),U,2)=""
97 .Q
98 S WVX=0
99 F S WVX=$O(^WV(790.04,WVX)) Q:WVX'>0 D
100 .F WVY=5,6 S $P(^WV(790.04,WVX,0),U,WVY)=""
101 .Q
102 S WVX=0
103 F S WVX=$O(^WV(790.05,WVX)) Q:WVX'>0 D
104 .F WVY=5,6 S $P(^WV(790.05,WVX,0),U,WVY)=""
105 .Q
106 K WVDOD,WVQUAD,WVX,WVY
107 Q
108CREDIT ; Stuff Credit Method value from Radiology/NM
109 ; "E" x-ref on File 790.1 is rad/nm date-case # (e.g., 060898-94)
110 Q:'$D(^RADPT) ;no Radiology/NM Patient file (#70)
111 S WVX=""
112 F S WVX=$O(^WV(790.1,"E",WVX)) Q:WVX="" S WVY=0 F S WVY=$O(^WV(790.1,"E",WVX,WVY)) Q:'WVY D
113 .S WVNODE=$G(^WV(790.1,WVY,0)) Q:WVNODE=""
114 .S WVDFN=$P(WVNODE,U,2) Q:WVDFN=""
115 .D RADCHK
116 .Q:WVCM="" ;no credit method
117 .S $P(^WV(790.1,WVY,0),U,35)=WVCM
118 .Q
119 K WVCASE,WVCM,WVDATE,WVDFN,WVNODE,WVX,WVY
120 Q
121RADCHK ; Get RAD/NM Patient Credit Method value
122 S WVCM=""
123 Q:'$D(^RADPT("ADC",WVX,WVDFN)) ;e.g., ^RADPT("ADC","060898-94",DFN))
124 S WVDATE=0
125 F S WVDATE=$O(^RADPT("ADC",WVX,WVDFN,WVDATE)) Q:'WVDATE S WVCASE=0 F S WVCASE=$O(^RADPT("ADC",WVX,WVDFN,WVDATE,WVCASE)) Q:'WVCASE D
126 .S WVCM=$P($G(^RADPT(WVDFN,"DT",WVDATE,"P",WVCASE,0)),U,26)
127 .Q
128 K WVCASE,WVDATE
129 Q
Note: See TracBrowser for help on using the repository browser.