PXUACM.m

PXUACM ; ISA/KWP - Convert PCE Mapping File and Immunization file ;3/3/1999

 ;;1.0;PCE PATIENT CARE ENCOUNTER;**66**;AUG 12, 1996

 ; CONVERT(CHANGE,REPORT)

 ; CHANGE = 0: don't change anything.default.

 ;          1: make changes.

 ; REPORT = 0: no feedback.default.

 ;          1 = errors only.

 ;          2 = errors, warnings.

 ;          3 = errors, warnings, diagnostics.

 ; Return value: 1 = success.

 ;               0 = failure.

 W !,"Incorrect entry point. This program must be utilized through"

 W !,"the Extrinsic Function. For example: SET RESULT=$$CONVERT(1,2)"

 W !,"See program comments for parameter definitions."

 Q

CONVERT(CHANGE,REPORT) ;see comments above

 N U,S,ERROR S U="^",S=";",ERROR=0

 S CHANGE=$G(CHANGE,0),REPORT=$G(REPORT,0)

 I REPORT=3 W !,"Building INACT and NEW arrays."

 D BUILD("IA",.INACT)

 D BUILD("NW",.NEW)

 I REPORT=3 W !,"Processing Inactive Codes:"

 D INACT I ERROR G CQ

 I REPORT=3 W !!,"Processing New Codes:"

 D NEW

CQ Q $S(ERROR:0,1:1)

BUILD(TYPE,ARR) ;TYPE-IA or NW, ARR-INACT or NEW

 N I,T

 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))

 Q

INACT ;Inactivate subroutine

 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

 .;check new entry to see if already added

 .I $D(NEW($P(MAP,S)))!($D(NEW($P($P(MAP,U,2),S)))) D

 ..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

 .;do inactivate

 .I $D(INACT($P(MAP,S)))!($D(INACT($P($P(MAP,U,2),S)))) D

 ..S CPIECE=$S($P(MAP,U)["ICPT":1,1:2)

 ..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

 ..I CHANGE S DIE=811.1,DA=INO,DR=".05////0",DUZ(0)="" D ^DIE

 ..I REPORT=3 W " Map Code Inactivated."

 ..I CHANGE S DIE="^AUTTIMM(",DA=$P($P(MAP,U,$S(CPIECE=1:2,1:1)),S),DR=".07////1",DUZ(0)="" D ^DIE

 ..I REPORT=3 W " IMM Inactivated."

 ..S $P(INACT($P($P(MAP,U,CPIECE),S)),U,CPIECE)=1

 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."

 Q

NODE ;0 node of the map entry missing

 S ERROR=1

 I REPORT W !," ERROR: Map 0 Node Missing." I REPORT=3 W "(^PXD(811.1,"_INO_",0)"

 Q

NEW ;New codes subroutine

 N CODE,DIC,DIE,DA,DR,SNAME,LNAME,X,Y,INO,IMINO,CERRFR,CERRTO

 ;remove new codes that have been added

 S CODE="" F  S CODE=$O(NEW(CODE)) Q:CODE=""  D NEW1 Q:ERROR

 Q

NEW1 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

 ;check immunization on file

 I CERRFR!CERRTO D  Q:ERROR

 .N LNAME2

 .S LNAME2=$P(^AUTTIMM($S(CERRFR:CERRFR,1:CERRTO),0),U)

 .I LNAME'=LNAME2 S ERROR=1 I REPORT W !,?5,"ERROR: Immunization for code "_CODE_" doesn't match update file."

 I CERRFR&CERRTO W:REPORT>1 !,"WARNING: Code "_CODE_" not added because from and to entries exist" Q

 I REPORT=3 W !,?5,"Adding: "_CODE_"."

 ;see PXTTU1 to see AUTTIMM numbering system.

 ;add new immunization

 I CERRTO!CERRFR I REPORT=3 W " IMM exist."

 I CHANGE I +CERRFR=0&(+CERRTO=0) D  Q:ERROR

 .S $P(^AUTTIMM(0),"^",3)=0

 .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

 .S IMINO=$P(Y,U),$P(^AUTTIMM(IMINO,0),U,2)=SNAME,DIK="^AUTTIMM(",DA=IMINO D IX1^DIK

 .I REPORT=3 W " IMM added."

 ;add imm-cpt map entry

 I CERRTO,REPORT=3 W " IMM-CPT map exist."

 I CHANGE,'CERRTO D  Q:ERROR

 .I CERRFR S IMINO=CERRFR

 .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

 .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

 .I REPORT=3 W " IMM-CPT map added."

 ;add cpt-imm map entry

 I CERRFR,REPORT=3 W " CPT-IMM map exist."

 I CHANGE,'CERRFR D  Q:ERROR

 .I CERRFR S IMINO=CERRTO

 .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

 .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

 .I REPORT=3 W " CPT-IMM map added."

 Q

IA ;These codes will be deleted from the map.  The corresponding

 ;immunization will be inactivated.

 ;90711^COMBINED VACCINE

 ;90714^TYPHOID IMMUNIZATION

 ;90724^INFLUENZA IMMUNIZATION

 ;90726^RABIES IMMUNIZATION

 ;90728^BCG IMMUNIZATION

 ;90730^HEPATITIS A VACCINE

 ;90737^INFLUENZA B IMMUNIZATION

 ;//

NW ;These codes will be added to the map.  The second and third

 ;piece will be added to the immunization file.

 ;90476^ADENOVIRUS,TYPE 4^ADEN TYP4^

 ;90477^ADENOVIRUS,TYPE 7^ADEN TYP7^

 ;90581^ANTHRAX,SC^ANT SC^

 ;90585^BCG,PERCUT^BCG P^

 ;90586^BCG,INTRAVESICAL^BCG I^

 ;90592^CHOLERA, ORAL^CHOL ORAL^

 ;90632^HEPA ADULT^HEPA AD^

 ;90633^HEPA,PED/ADOL-2^HEPA PED/ADOL-2^

 ;90634^HEPA,PED/ADOL-3 DOSE^HEPA PED/ADOL-3^

 ;90636^HEPA/HEPB ADULT^HEPA/HEPB AD^

 ;90645^HIB,HBOC^HIB,HBOC^

 ;90646^HIB,PRP-D^HIB PRP-D^

 ;90647^HIB,PRP-OMP^HIB PRP-OMP^

 ;90648^HIB,PRP-T^HIB PRP-T^

 ;90658^FLU,3 YRS^FLU 3YRS^

 ;90659^FLU,WHOLE^FLU WHOLE^

 ;90660^FLU,NASAL^FLU NAS^

 ;90665^LYME DISEASE^LYME

 ;90669^PNEUMOCOCCAL,PED^PNEUMO-PED

 ;90675^RABIES,IM^RAB

 ;90676^RABIES,ID^RAB ID

 ;90680^ROTOVIRUS,ORAL^ROTO ORAL

 ;90690^TYPHOID,ORAL^TYP ORAL

 ;90691^TYPHOID^TYP

 ;90692^TYPHOID,H-P,SC/ID^TYP H-P-SC/ID

 ;90693^TYPHOID,AKD,SC^TYP AKD-SC

 ;90747^HEPB, ILL PAT^HEPB ILL

 ;90748^HEPB/HIB^HEPB/HIB

 ;//

R S RESULT=$$CONVERT(1,3)

 Q

PXUACM    ; ISA/KWP - Convert PCE Mapping File and Immunization file ;3/3/1999

 +1       ;;1.0;PCE PATIENT CARE ENCOUNTER;**66**;AUG 12, 1996

 +2       ; CONVERT(CHANGE,REPORT)

 +3       ; CHANGE = 0: don't change anything.default.

 +4       ;          1: make changes.

 +5       ; REPORT = 0: no feedback.default.

 +6       ;          1 = errors only.

 +7       ;          2 = errors, warnings.

 +8       ;          3 = errors, warnings, diagnostics.

 +9       ; Return value: 1 = success.

 +10      ;               0 = failure.

 +11       WRITE !,"Incorrect entry point. This program must be utilized through"

 +12       WRITE !,"the Extrinsic Function. For example: SET RESULT=$$CONVERT(1,2)"

 +13       WRITE !,"See program comments for parameter definitions."

 +14       QUIT 

CONVERT(CHANGE,REPORT) ;see comments above

 +1        NEW U,S,ERROR

           SET U="^"

           SET S=";"

           SET ERROR=0

 +2        SET CHANGE=$GET(CHANGE,0)

           SET REPORT=$GET(REPORT,0)

 +3        IF REPORT=3

               WRITE !,"Building INACT and NEW arrays."

 +4        DO BUILD("IA",.INACT)

 +5        DO BUILD("NW",.NEW)

 +6        IF REPORT=3

               WRITE !,"Processing Inactive Codes:"

 +7        DO INACT

           IF ERROR

               GOTO CQ

 +8        IF REPORT=3

               WRITE !!,"Processing New Codes:"

 +9        DO NEW

CQ         QUIT $SELECT(ERROR:0,1:1)

BUILD(TYPE,ARR) ;TYPE-IA or NW, ARR-INACT or NEW

 +1        NEW I,T

 +2        FOR I=2:1

               SET T=$PIECE($TEXT(@TYPE+I),";",2)

               IF T["//"

                   QUIT 

               SET ARR($PIECE(T,U))=$SELECT(TYPE="IA":"",1:$PIECE(T,U,2,3))

 +3        QUIT 

INACT     ;Inactivate subroutine

 +1        NEW CPIECE,INO,MAP,DIE,DA,DR,IMM

           SET INO=0

           FOR 

               SET INO=$ORDER(^PXD(811.1,INO))

               IF 'INO

                   QUIT 

               SET MAP=$GET(^PXD(811.1,INO,0))

               IF MAP=""

                   DO NODE

               IF 'ERROR

                   IF REPORT=3

                       WRITE !,?5,MAP

                   Begin DoDot:1

 +2       ;check new entry to see if already added

 +3                    IF $DATA(NEW($PIECE(MAP,S)))!($DATA(NEW($PIECE($PIECE(MAP,U,2),S))))

                           Begin DoDot:2

 +4                            SET CPIECE=$SELECT($PIECE(MAP,U)["ICPT":1,1:2)

                               SET IMM=$PIECE($PIECE(MAP,U,$SELECT(CPIECE=1:2,1:1)),S)

                               SET $PIECE(NEW($PIECE($PIECE(MAP,U,CPIECE),S)),U,(2+CPIECE))=IMM

                           End DoDot:2

 +5       ;do inactivate

 +6                    IF $DATA(INACT($PIECE(MAP,S)))!($DATA(INACT($PIECE($PIECE(MAP,U,2),S))))

                           Begin DoDot:2

 +7                            SET CPIECE=$SELECT($PIECE(MAP,U)["ICPT":1,1:2)

 +8                            IF '$PIECE(MAP,U,5)

                                   IF REPORT>1

                                       WRITE !," WARNING: Map already Turned Off."

                                   SET $PIECE(INACT($PIECE($PIECE(MAP,U,CPIECE),S)),U,CPIECE)=1

                                   QUIT 

 +9                            IF CHANGE

                                   SET DIE=811.1

                                   SET DA=INO

                                   SET DR=".05////0"

                                   SET DUZ(0)=""

                                   DO ^DIE

 +10                           IF REPORT=3

                                   WRITE " Map Code Inactivated."

 +11                           IF CHANGE

                                   SET DIE="^AUTTIMM("

                                   SET DA=$PIECE($PIECE(MAP,U,$SELECT(CPIECE=1:2,1:1)),S)

                                   SET DR=".07////1"

                                   SET DUZ(0)=""

                                   DO ^DIE

 +12                           IF REPORT=3

                                   WRITE " IMM Inactivated."

 +13                           SET $PIECE(INACT($PIECE($PIECE(MAP,U,CPIECE),S)),U,CPIECE)=1

                           End DoDot:2

                   End DoDot:1

 +14       IF REPORT>1

               SET INO=""

               FOR 

                   SET INO=$ORDER(INACT(INO))

                   IF INO=""

                       QUIT 

                   SET MAP=INACT(INO)

                   IF $PIECE(MAP,U)'=1!($PIECE(MAP,U,2)'=1)

                       WRITE !,"WARNING: Code "_INO_" does not contain a from/to entry to turn off in the map."

 +15       QUIT 

NODE      ;0 node of the map entry missing

 +1        SET ERROR=1

 +2        IF REPORT

               WRITE !," ERROR: Map 0 Node Missing."

               IF REPORT=3

                   WRITE "(^PXD(811.1,"_INO_",0)"

 +3        QUIT 

NEW       ;New codes subroutine

 +1        NEW CODE,DIC,DIE,DA,DR,SNAME,LNAME,X,Y,INO,IMINO,CERRFR,CERRTO

 +2       ;remove new codes that have been added

 +3        SET CODE=""

           FOR 

               SET CODE=$ORDER(NEW(CODE))

               IF CODE=""

                   QUIT 

               DO NEW1

               IF ERROR

                   QUIT 

 +4        QUIT 

NEW1       SET LNAME=$PIECE(NEW(CODE),U)

           SET SNAME=$PIECE(NEW(CODE),U,2)

           SET CERRFR=$PIECE(NEW(CODE),U,3)

           SET CERRTO=$PIECE(NEW(CODE),U,4)

           SET IMINO=0

 +1       ;check immunization on file

 +2        IF CERRFR!CERRTO

               Begin DoDot:1

 +3                NEW LNAME2

 +4                SET LNAME2=$PIECE(^AUTTIMM($SELECT(CERRFR:CERRFR,1:CERRTO),0),U)

 +5                IF LNAME'=LNAME2

                       SET ERROR=1

                       IF REPORT

                           WRITE !,?5,"ERROR: Immunization for code "_CODE_" doesn't match update file."

               End DoDot:1

               IF ERROR

                   QUIT 

 +6        IF CERRFR&CERRTO

               IF REPORT>1

                   WRITE !,"WARNING: Code "_CODE_" not added because from and to entries exist"

               QUIT 

 +7        IF REPORT=3

               WRITE !,?5,"Adding: "_CODE_"."

 +8       ;see PXTTU1 to see AUTTIMM numbering system.

 +9       ;add new immunization

 +10       IF CERRTO!CERRFR

               IF REPORT=3

                   WRITE " IMM exist."

 +11       IF CHANGE

               IF +CERRFR=0&(+CERRTO=0)

                   Begin DoDot:1

 +12                   SET $PIECE(^AUTTIMM(0),"^",3)=0

 +13                   SET DIC="^AUTTIMM("

                       SET DIC(0)=""

                       SET X=LNAME

                       KILL DD,DO

                       DO FILE^DICN

                       IF Y<0

                           IF REPORT

                               WRITE !,?5,"ERROR: Fileman error saving immunization"

                           IF REPORT=3

                               WRITE "-"_LNAME

                           SET ERROR=1

                           QUIT 

 +14                   SET IMINO=$PIECE(Y,U)

                       SET $PIECE(^AUTTIMM(IMINO,0),U,2)=SNAME

                       SET DIK="^AUTTIMM("

                       SET DA=IMINO

                       DO IX1^DIK

 +15                   IF REPORT=3

                           WRITE " IMM added."

                   End DoDot:1

                   IF ERROR

                       QUIT 

 +16      ;add imm-cpt map entry

 +17       IF CERRTO

               IF REPORT=3

                   WRITE " IMM-CPT map exist."

 +18       IF CHANGE

               IF 'CERRTO

                   Begin DoDot:1

 +19                   IF CERRFR

                           SET IMINO=CERRFR

 +20                   SET DIC="^PXD(811.1,"

                       SET DIC(0)=""

                       SET X=IMINO_";AUTTIMM("

                       KILL DD,DO

                       DO FILE^DICN

                       IF Y<0

                           IF REPORT

                               WRITE !,?5,"ERROR: Fileman error saving imm-cpt map entry"

                           IF REPORT=3

                               WRITE "-"_X

                           SET ERROR=1

                           QUIT 

 +21                   SET INO=$PIECE(Y,U)

                       SET $PIECE(^PXD(811.1,INO,0),U,2)=CODE_";ICPT(^IMM^CPT^1"

                       SET DIK="^PXD(811.1,"

                       SET DA=INO

                       DO IX1^DIK

 +22                   IF REPORT=3

                           WRITE " IMM-CPT map added."

                   End DoDot:1

                   IF ERROR

                       QUIT 

 +23      ;add cpt-imm map entry

 +24       IF CERRFR

               IF REPORT=3

                   WRITE " CPT-IMM map exist."

 +25       IF CHANGE

               IF 'CERRFR

                   Begin DoDot:1

 +26                   IF CERRFR

                           SET IMINO=CERRTO

 +27                   SET DIC="^PXD(811.1,"

                       SET DIC(0)=""

                       SET X=CODE_";ICPT("

                       KILL DD,DO

                       DO FILE^DICN

                       IF Y<0

                           IF REPORT

                               WRITE !,?5,"ERROR: Fileman error saving cpt-imm map entry"

                           IF REPORT=3

                               WRITE "-"_X

                           SET ERROR=1

                           QUIT 

 +28                   SET INO=$PIECE(Y,U)

                       SET $PIECE(^PXD(811.1,INO,0),U,2)=IMINO_";AUTTIMM(^CPT^IMM^1"

                       SET DIK="^PXD(811.1,"

                       SET DA=INO

                       DO IX1^DIK

 +29                   IF REPORT=3

                           WRITE " CPT-IMM map added."

                   End DoDot:1

                   IF ERROR

                       QUIT 

 +30       QUIT 

IA        ;These codes will be deleted from the map.  The corresponding

 +1       ;immunization will be inactivated.

 +2       ;90711^COMBINED VACCINE

 +3       ;90714^TYPHOID IMMUNIZATION

 +4       ;90724^INFLUENZA IMMUNIZATION

 +5       ;90726^RABIES IMMUNIZATION

 +6       ;90728^BCG IMMUNIZATION

 +7       ;90730^HEPATITIS A VACCINE

 +8       ;90737^INFLUENZA B IMMUNIZATION

 +9       ;//

NW        ;These codes will be added to the map.  The second and third

 +1       ;piece will be added to the immunization file.

 +2       ;90476^ADENOVIRUS,TYPE 4^ADEN TYP4^

 +3       ;90477^ADENOVIRUS,TYPE 7^ADEN TYP7^

 +4       ;90581^ANTHRAX,SC^ANT SC^

 +5       ;90585^BCG,PERCUT^BCG P^

 +6       ;90586^BCG,INTRAVESICAL^BCG I^

 +7       ;90592^CHOLERA, ORAL^CHOL ORAL^

 +8       ;90632^HEPA ADULT^HEPA AD^

 +9       ;90633^HEPA,PED/ADOL-2^HEPA PED/ADOL-2^

 +10      ;90634^HEPA,PED/ADOL-3 DOSE^HEPA PED/ADOL-3^

 +11      ;90636^HEPA/HEPB ADULT^HEPA/HEPB AD^

 +12      ;90645^HIB,HBOC^HIB,HBOC^

 +13      ;90646^HIB,PRP-D^HIB PRP-D^

 +14      ;90647^HIB,PRP-OMP^HIB PRP-OMP^

 +15      ;90648^HIB,PRP-T^HIB PRP-T^

 +16      ;90658^FLU,3 YRS^FLU 3YRS^

 +17      ;90659^FLU,WHOLE^FLU WHOLE^

 +18      ;90660^FLU,NASAL^FLU NAS^

 +19      ;90665^LYME DISEASE^LYME

 +20      ;90669^PNEUMOCOCCAL,PED^PNEUMO-PED

 +21      ;90675^RABIES,IM^RAB

 +22      ;90676^RABIES,ID^RAB ID

 +23      ;90680^ROTOVIRUS,ORAL^ROTO ORAL

 +24      ;90690^TYPHOID,ORAL^TYP ORAL

 +25      ;90691^TYPHOID^TYP

 +26      ;90692^TYPHOID,H-P,SC/ID^TYP H-P-SC/ID

 +27      ;90693^TYPHOID,AKD,SC^TYP AKD-SC

 +28      ;90747^HEPB, ILL PAT^HEPB ILL

 +29      ;90748^HEPB/HIB^HEPB/HIB

 +30      ;//

R          SET RESULT=$$CONVERT(1,3)

 +1        QUIT