source: WorldVistAEHR/trunk/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXUACM.m@ 1773

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

initial load of WorldVistAEHR

File size: 5.6 KB
Line 
1PXUACM ; ISA/KWP - Convert PCE Mapping File and Immunization file ;3/3/1999
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**66**;AUG 12, 1996
3 ; CONVERT(CHANGE,REPORT)
4 ; CHANGE = 0: don't change anything.default.
5 ; 1: make changes.
6 ; REPORT = 0: no feedback.default.
7 ; 1 = errors only.
8 ; 2 = errors, warnings.
9 ; 3 = errors, warnings, diagnostics.
10 ; Return value: 1 = success.
11 ; 0 = failure.
12 W !,"Incorrect entry point. This program must be utilized through"
13 W !,"the Extrinsic Function. For example: SET RESULT=$$CONVERT(1,2)"
14 W !,"See program comments for parameter definitions."
15 Q
16CONVERT(CHANGE,REPORT) ;see comments above
17 N U,S,ERROR S U="^",S=";",ERROR=0
18 S CHANGE=$G(CHANGE,0),REPORT=$G(REPORT,0)
19 I REPORT=3 W !,"Building INACT and NEW arrays."
20 D BUILD("IA",.INACT)
21 D BUILD("NW",.NEW)
22 I REPORT=3 W !,"Processing Inactive Codes:"
23 D INACT I ERROR G CQ
24 I REPORT=3 W !!,"Processing New Codes:"
25 D NEW
26CQ Q $S(ERROR:0,1:1)
27BUILD(TYPE,ARR) ;TYPE-IA or NW, ARR-INACT or NEW
28 N I,T
29 F I=2:1 S T=$P($T(@TYPE+I),";",2) Q:T["//" S ARR($P(T,U))=$S(TYPE="IA":"",1:$P(T,U,2,3))
30 Q
31INACT ;Inactivate subroutine
32 N CPIECE,INO,MAP,DIE,DA,DR,IMM S INO=0 F S INO=$O(^PXD(811.1,INO)) Q:'INO S MAP=$G(^PXD(811.1,INO,0)) D:MAP="" NODE I 'ERROR W:REPORT=3 !,?5,MAP D
33 .;check new entry to see if already added
34 .I $D(NEW($P(MAP,S)))!($D(NEW($P($P(MAP,U,2),S)))) D
35 ..S CPIECE=$S($P(MAP,U)["ICPT":1,1:2),IMM=$P($P(MAP,U,$S(CPIECE=1:2,1:1)),S),$P(NEW($P($P(MAP,U,CPIECE),S)),U,(2+CPIECE))=IMM
36 .;do inactivate
37 .I $D(INACT($P(MAP,S)))!($D(INACT($P($P(MAP,U,2),S)))) D
38 ..S CPIECE=$S($P(MAP,U)["ICPT":1,1:2)
39 ..I '$P(MAP,U,5) W:REPORT>1 !," WARNING: Map already Turned Off." S $P(INACT($P($P(MAP,U,CPIECE),S)),U,CPIECE)=1 Q
40 ..I CHANGE S DIE=811.1,DA=INO,DR=".05////0",DUZ(0)="" D ^DIE
41 ..I REPORT=3 W " Map Code Inactivated."
42 ..I CHANGE S DIE="^AUTTIMM(",DA=$P($P(MAP,U,$S(CPIECE=1:2,1:1)),S),DR=".07////1",DUZ(0)="" D ^DIE
43 ..I REPORT=3 W " IMM Inactivated."
44 ..S $P(INACT($P($P(MAP,U,CPIECE),S)),U,CPIECE)=1
45 I REPORT>1 S INO="" F S INO=$O(INACT(INO)) Q:INO="" S MAP=INACT(INO) I $P(MAP,U)'=1!($P(MAP,U,2)'=1) W !,"WARNING: Code "_INO_" does not contain a from/to entry to turn off in the map."
46 Q
47NODE ;0 node of the map entry missing
48 S ERROR=1
49 I REPORT W !," ERROR: Map 0 Node Missing." I REPORT=3 W "(^PXD(811.1,"_INO_",0)"
50 Q
51NEW ;New codes subroutine
52 N CODE,DIC,DIE,DA,DR,SNAME,LNAME,X,Y,INO,IMINO,CERRFR,CERRTO
53 ;remove new codes that have been added
54 S CODE="" F S CODE=$O(NEW(CODE)) Q:CODE="" D NEW1 Q:ERROR
55 Q
56NEW1 S LNAME=$P(NEW(CODE),U),SNAME=$P(NEW(CODE),U,2),CERRFR=$P(NEW(CODE),U,3),CERRTO=$P(NEW(CODE),U,4),IMINO=0
57 ;check immunization on file
58 I CERRFR!CERRTO D Q:ERROR
59 .N LNAME2
60 .S LNAME2=$P(^AUTTIMM($S(CERRFR:CERRFR,1:CERRTO),0),U)
61 .I LNAME'=LNAME2 S ERROR=1 I REPORT W !,?5,"ERROR: Immunization for code "_CODE_" doesn't match update file."
62 I CERRFR&CERRTO W:REPORT>1 !,"WARNING: Code "_CODE_" not added because from and to entries exist" Q
63 I REPORT=3 W !,?5,"Adding: "_CODE_"."
64 ;see PXTTU1 to see AUTTIMM numbering system.
65 ;add new immunization
66 I CERRTO!CERRFR I REPORT=3 W " IMM exist."
67 I CHANGE I +CERRFR=0&(+CERRTO=0) D Q:ERROR
68 .S $P(^AUTTIMM(0),"^",3)=0
69 .S DIC="^AUTTIMM(",DIC(0)="",X=LNAME K DD,DO D FILE^DICN I Y<0 W:REPORT !,?5,"ERROR: Fileman error saving immunization" W:REPORT=3 "-"_LNAME S ERROR=1 Q
70 .S IMINO=$P(Y,U),$P(^AUTTIMM(IMINO,0),U,2)=SNAME,DIK="^AUTTIMM(",DA=IMINO D IX1^DIK
71 .I REPORT=3 W " IMM added."
72 ;add imm-cpt map entry
73 I CERRTO,REPORT=3 W " IMM-CPT map exist."
74 I CHANGE,'CERRTO D Q:ERROR
75 .I CERRFR S IMINO=CERRFR
76 .S DIC="^PXD(811.1,",DIC(0)="",X=IMINO_";AUTTIMM(" K DD,DO D FILE^DICN I Y<0 W:REPORT !,?5,"ERROR: Fileman error saving imm-cpt map entry" W:REPORT=3 "-"_X S ERROR=1 Q
77 .S INO=$P(Y,U),$P(^PXD(811.1,INO,0),U,2)=CODE_";ICPT(^IMM^CPT^1",DIK="^PXD(811.1,",DA=INO D IX1^DIK
78 .I REPORT=3 W " IMM-CPT map added."
79 ;add cpt-imm map entry
80 I CERRFR,REPORT=3 W " CPT-IMM map exist."
81 I CHANGE,'CERRFR D Q:ERROR
82 .I CERRFR S IMINO=CERRTO
83 .S DIC="^PXD(811.1,",DIC(0)="",X=CODE_";ICPT(" K DD,DO D FILE^DICN I Y<0 W:REPORT !,?5,"ERROR: Fileman error saving cpt-imm map entry" W:REPORT=3 "-"_X S ERROR=1 Q
84 .S INO=$P(Y,U),$P(^PXD(811.1,INO,0),U,2)=IMINO_";AUTTIMM(^CPT^IMM^1",DIK="^PXD(811.1,",DA=INO D IX1^DIK
85 .I REPORT=3 W " CPT-IMM map added."
86 Q
87IA ;These codes will be deleted from the map. The corresponding
88 ;immunization will be inactivated.
89 ;90711^COMBINED VACCINE
90 ;90714^TYPHOID IMMUNIZATION
91 ;90724^INFLUENZA IMMUNIZATION
92 ;90726^RABIES IMMUNIZATION
93 ;90728^BCG IMMUNIZATION
94 ;90730^HEPATITIS A VACCINE
95 ;90737^INFLUENZA B IMMUNIZATION
96 ;//
97NW ;These codes will be added to the map. The second and third
98 ;piece will be added to the immunization file.
99 ;90476^ADENOVIRUS,TYPE 4^ADEN TYP4^
100 ;90477^ADENOVIRUS,TYPE 7^ADEN TYP7^
101 ;90581^ANTHRAX,SC^ANT SC^
102 ;90585^BCG,PERCUT^BCG P^
103 ;90586^BCG,INTRAVESICAL^BCG I^
104 ;90592^CHOLERA, ORAL^CHOL ORAL^
105 ;90632^HEPA ADULT^HEPA AD^
106 ;90633^HEPA,PED/ADOL-2^HEPA PED/ADOL-2^
107 ;90634^HEPA,PED/ADOL-3 DOSE^HEPA PED/ADOL-3^
108 ;90636^HEPA/HEPB ADULT^HEPA/HEPB AD^
109 ;90645^HIB,HBOC^HIB,HBOC^
110 ;90646^HIB,PRP-D^HIB PRP-D^
111 ;90647^HIB,PRP-OMP^HIB PRP-OMP^
112 ;90648^HIB,PRP-T^HIB PRP-T^
113 ;90658^FLU,3 YRS^FLU 3YRS^
114 ;90659^FLU,WHOLE^FLU WHOLE^
115 ;90660^FLU,NASAL^FLU NAS^
116 ;90665^LYME DISEASE^LYME
117 ;90669^PNEUMOCOCCAL,PED^PNEUMO-PED
118 ;90675^RABIES,IM^RAB
119 ;90676^RABIES,ID^RAB ID
120 ;90680^ROTOVIRUS,ORAL^ROTO ORAL
121 ;90690^TYPHOID,ORAL^TYP ORAL
122 ;90691^TYPHOID^TYP
123 ;90692^TYPHOID,H-P,SC/ID^TYP H-P-SC/ID
124 ;90693^TYPHOID,AKD,SC^TYP AKD-SC
125 ;90747^HEPB, ILL PAT^HEPB ILL
126 ;90748^HEPB/HIB^HEPB/HIB
127 ;//
128R S RESULT=$$CONVERT(1,3)
129 Q
Note: See TracBrowser for help on using the repository browser.