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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXUACM 5822 printed Dec 13, 2024@02:31:34 Page 2
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
