source: WorldVistAEHR/trunk/r/ONCOLOGY-ONC/ONCOPST1.m@ 1259

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

initial load of WorldVistAEHR

File size: 5.7 KB
Line 
1ONCOPST1 ;HIRMFO/RTK-DATA CONVERSION CALLED BY ONCOPST ;2/7/96
2 ;;2.11;ONCOLOGY;**1,4**;Feb 07, 1996
3 ;
4 ;Routine to convert data in several fields in the ONCOLOGY PRIMARY
5 ;file from pointers to the ONCOLOGY CONTACT file to pointers to the
6 ;new ACOS NUMBER file. Pointers in the following fields in the
7 ;ONCOLOGY PRIMARY file will be converted: 5,6,7,50.1,51.1,52.1,53.1,
8 ;54.1,55.1,56.1,57.1 and SUB-FIELD 2 under field 60. This routine
9 ;also calls ^ONCOPST2, ^ONCOPST3 and ^ONCOPST4.
10 ;
11 ;W !!," Converting pointers to the ONCOLOGY CONTACT (165) file to pointers to the new"
12 ;W !," ACOS NUMBER (160.19) file..."
13 D ^ONCOPST3 ;Routine to loop thru 165 file add any new entries to 160.19
14 S FIRST=$O(^ONCO(165.5,0)) Q:FIRST="" I $P($G(^ONCO(165.5,FIRST,24)),"^",6)="" D
15 .F XFIRST=0:0 S XFIRST=$O(^ONCO(165.5,XFIRST)) Q:XFIRST'>"" S $P(^ONCO(165.5,XFIRST,24),"^",6)="N"
16 K ^TMP($J,"CONTINV"),^TMP($J,"NOTFND") S CNT=0
17 F XPRI=0:0 S XPRI=$O(^ONCO(165.5,XPRI)) Q:XPRI'>"" D
18 .S CNT=CNT+1 I CNT#100=0 W "."
19 .Q:$P($G(^ONCO(165.5,XPRI,24)),"^",6)'="N"
20 .D GETFLDS S NOTFOUND=0
21 .S XXX="" F S XXX=$O(PRIM(XXX)) Q:XXX="" S CONPTR=$G(PRIM(XXX)) D
22 ..S CONTACT=$G(^ONCO(165,CONPTR,0)),NEWACOS=$P($G(^ONCO(165,CONPTR,0)),"^",4)
23 ..I CONTACT="" D DELETE Q
24 ..I NEWACOS=""!(NEWACOS'?1"#"6N) S NOTFOUND=1,^TMP($J,"CONTINV",CONPTR)="" Q
25 ..I NEWACOS?1"#"6N S NEWACOS=$E(NEWACOS,2,7)
26 ..S ACOSIEN=$O(^ONCO(160.19,"B",NEWACOS,"")) I ACOSIEN="" S NOTFOUND=1,^TMP($J,"NOTFND",CONPTR)="" Q
27 ..I ACOSIEN'="" D CONV
28 ..Q
29 .I NOTFOUND=1 S $P(^ONCO(165.5,XPRI,24),"^",6)="N" K PRIM,Z0,Z3,ZZ4 Q
30 .I NOTFOUND'=1,$O(PRIM(""))'="" S ^ONCO(165.5,XPRI,0)=Z0,^ONCO(165.5,XPRI,3)=Z3 F X=0:0 S X=$O(ZZ4(X)) Q:X'>0 S ^ONCO(165.5,XPRI,4,X,0)=ZZ4(X)
31 .I NOTFOUND'=1 S $P(^ONCO(165.5,XPRI,24),"^",6)="Y"
32 .K PRIM,Z0,Z3,ZZ4 Q
33 D ^ONCOPST2 ;routine to loop thru 160 file and convert field #24.5.
34 I $O(^TMP($J,"CONTINV",""))'="" D
35 .W !!?5,"Pointers to the following entries in the ONCOLOGY CONTACT (165) file could"
36 .W !?5,"not be converted to point to the new ACOS NUMBER (160.19) file due to"
37 .W !?5,"missing or invalid ACOS number data in the COMMENTS field (#3) of the"
38 .W !?5,"ONCOLOGY CONTACT file:",!
39 .W !,$J("Record #",15)," Name"
40 .W !,$J("--------",15)," ----"
41 .F X=0:0 S X=$O(^TMP($J,"CONTINV",X)) Q:X'>0 W !,$J(X,15)," ",$P($G(^ONCO(165,X,0)),"^")
42 .Q
43 I $O(^TMP($J,"NOTFND",""))'="" D
44 .W !!?5,"Pointers to the following entries in the ONCOLOGY CONTACT (165) file could"
45 .W !?5,"not be converted to point to the new ACOS NUMBER (160.19) file due to an"
46 .W !?5,"entry in the COMMENTS field (#3) of the ONCOLOGY CONTACT file that could"
47 .W !?5,"not be found in the ACOS NUMBER file:",!
48 .W !,$J("Record #",15)," Name",?50,"# not found"
49 .W !,$J("--------",15)," ----",?50,"-----------"
50 .F X=0:0 S X=$O(^TMP($J,"NOTFND",X)) Q:X'>0 W !,$J(X,15)," ",$E($P($G(^ONCO(165,X,0)),"^"),1,30),?50,$P(^ONCO(165,X,0),"^",4)
51 .Q
52 I $O(^TMP($J,"CONTINV",""))'=""!($O(^TMP($J,"NOTFND",""))'="") D
53 .W !!!?5,"Please ask the ONCOLOGY ADPAC to enter the correct ACOS numbers for the"
54 .W !?5,"above entries in the COMMENTS field (#3) of the ONCOLOGY CONTACT (165)"
55 .W !?5,"file. Enter the ACOS number in the format '#nnnnnn' where 'nnnnnn' is the"
56 .W !?5,"6-digit ACOS number, e.g. '#431910'. For an ONCOLOGY CONCTACT that does"
57 .W !?5,"not have an assigned ACOS number, enter a single '#' character and an entry"
58 .W !?5,"will be added to the ACOS NUMBER file with a computed ACOS number.",!
59 .W !?5,"When the correct numbers (or '#' characters) have been entered in the"
60 .W !?5,"COMMENTS field, re-run the conversion by entering D ^ONCOPST1. Continue"
61 .W !?5,"this process until there are no exceptions."
62 .Q
63 I $O(^TMP($J,"CONTINV",""))="",$O(^TMP($J,"NOTFND",""))="" W !!?5,"No conversion exceptions." D ^ONCOPST4
64 K ACOSIEN,ACOSIEN2,CCAD,CNT,CONTACT,CONTACT2,D,FIEN,FIRST,HOSPNAME,NEWACOS,NEWACOS2,NEWENTRY,NEWIEN,NEWNUM,NOTADD,NOTFOUND,PLACE,R,SUB,TMP,X,XCON,XFIRST,XPAT,XPRI,XXX,Z4
65 K ^TMP($J,"CONTINV"),^TMP($J,"NOTFND"),^TMP($J,"NOTADD")
66 Q
67GETFLDS ;
68 S Z0=$G(^ONCO(165.5,XPRI,0)),Z3=$G(^ONCO(165.5,XPRI,3)),Z4=$G(^ONCO(165.5,XPRI,4,0))
69 I $P(Z0,"^",17)'="" S PRIM("DXF")=$P(Z0,"^",17)
70 I $P(Z0,"^",18)'="" S PRIM("REF")=$P(Z0,"^",18)
71 I $P(Z0,"^",19)'="" S PRIM("TRF")=$P(Z0,"^",19)
72 I $P(Z3,"^",2)'="" S PRIM("SUR")=$P(Z3,"^",2)
73 I $P(Z3,"^",5)'="" S PRIM("RAD")=$P(Z3,"^",5)
74 I $P(Z3,"^",9)'="" S PRIM("CNS")=$P(Z3,"^",9)
75 I $P(Z3,"^",12)'="" S PRIM("CHE")=$P(Z3,"^",12)
76 I $P(Z3,"^",15)'="" S PRIM("HOR")=$P(Z3,"^",15)
77 I $P(Z3,"^",18)'="" S PRIM("BRM")=$P(Z3,"^",18)
78 I $P(Z3,"^",21)'="" S PRIM("HYP")=$P(Z3,"^",21)
79 I $P(Z3,"^",24)'="" S PRIM("OTH")=$P(Z3,"^",24)
80 I Z4="" Q
81 F SUB=0:0 S SUB=$O(^ONCO(165.5,XPRI,4,SUB)) Q:SUB'>0 D
82 .S ZZ4(SUB)=$G(^ONCO(165.5,XPRI,4,SUB,0)),PLACE="PLC"_SUB
83 .I $P(ZZ4(SUB),"^",3)'="" S PRIM(PLACE)=$P(ZZ4(SUB),"^",3)
84 .Q
85 Q
86CONV ;
87 I "DXF^REF^TRF"[XXX D Q ;make changes to Z0
88 .S R=$S(XXX="DXF":17,XXX="REF":18,XXX="TRF":19,1:999)
89 .I R'=999 S $P(Z0,"^",R)=ACOSIEN
90 .Q
91 I "SUR^RAD^CNS^CHE^HOR^BRM^HYP^OTH"[XXX D Q ;make changes to Z3
92 .S R=$S(XXX="SUR":2,XXX="RAD":5,XXX="CNS":9,XXX="CHE":12,XXX="HOR":15,XXX="BRM":18,XXX="HYP":21,XXX="OTH":24,1:999)
93 .I R'=999 S $P(Z3,"^",R)=ACOSIEN
94 .Q
95 I XXX["PLC" D Q ;make changes to ZZ4(SUB) array
96 .S R=$E(XXX,4,6),$P(ZZ4(R),"^",3)=ACOSIEN
97 .Q
98 Q
99DELETE ; Delete dangling pointers. If a field has a value which points to
100 ; an entry in the CONTACT (165) file that no longer exists, delete it
101 I XXX="" Q
102 I XXX'["PLC" D @XXX Q
103 I XXX["PLC" D PLC Q
104DXF S $P(Z0,"^",17)="" Q
105REF S $P(Z0,"^",18)="" Q
106TRF S $P(Z0,"^",19)="" Q
107SUR S $P(Z3,"^",2)="" Q
108RAD S $P(Z3,"^",5)="" Q
109CNS S $P(Z3,"^",9)="" Q
110CHE S $P(Z3,"^",12)="" Q
111HOR S $P(Z3,"^",15)="" Q
112BRM S $P(Z3,"^",18)="" Q
113HYP S $P(Z3,"^",21)="" Q
114OTH S $P(Z3,"^",24)="" Q
115PLC S R=$E(XXX,4,6),$P(ZZ4(R),"^",3)="" Q
Note: See TracBrowser for help on using the repository browser.