| 1 | ONCOPST1 ;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
|
---|
| 67 | GETFLDS ;
|
---|
| 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
|
---|
| 86 | CONV ;
|
---|
| 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
|
---|
| 99 | DELETE ; 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
|
---|
| 104 | DXF S $P(Z0,"^",17)="" Q
|
---|
| 105 | REF S $P(Z0,"^",18)="" Q
|
---|
| 106 | TRF S $P(Z0,"^",19)="" Q
|
---|
| 107 | SUR S $P(Z3,"^",2)="" Q
|
---|
| 108 | RAD S $P(Z3,"^",5)="" Q
|
---|
| 109 | CNS S $P(Z3,"^",9)="" Q
|
---|
| 110 | CHE S $P(Z3,"^",12)="" Q
|
---|
| 111 | HOR S $P(Z3,"^",15)="" Q
|
---|
| 112 | BRM S $P(Z3,"^",18)="" Q
|
---|
| 113 | HYP S $P(Z3,"^",21)="" Q
|
---|
| 114 | OTH S $P(Z3,"^",24)="" Q
|
---|
| 115 | PLC S R=$E(XXX,4,6),$P(ZZ4(R),"^",3)="" Q
|
---|