APCDFOA3 ; IHS/CMI/LAB - USER INTERFACE TO SELECT ICD CODES ;
;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
BEGIN ;
W !
S APCD("NO DISPLAY")=0
D ASK1
I Y="^" S APCDSTP=1 G X
I $D(APCDTABL) D CHECK I Y'=1 G @$S(Y=0:"BEGIN",1:"X")
X I $D(APCDTABL) D SETUTIL
D EOJ
Q
;
ASK1 ;
S APCDA=0
;WHAT CODING SYSTEM?
S APCDSYS=""
W !,"You must enter the coding system from which you want to enter a code,",!,"or range of codes.",!
S DIC="^ICDS(",DIC("S")="I $P(^(0),U,3)=80.1",DIC(0)="AEMQ" D ^DIC K DIC
I Y=-1 G X1
S APCDSYS=+Y
K APCD("LOW"),APCD("HI")
S DIR("A")=$S('$D(APCDTABL):"Enter Procedure (or range of procedure codes)",1:"Enter another Procedure (or range of procedure codes)") D SETDIR^APCDFOA4,^DIR K DIR
I "^"[Y G X1
D PROCESS
I $D(APCDTABL),'APCD("NO DISPLAY") D RANGES
S APCD("NO DISPLAY")=0
G ASK1
X1 Q
;
PROCESS ;EVALUATE USER RESPONSE
S (APCDSUB,APCDONE)=0 ;APCDSUB=0 => NO DELETE OF CODE(S),APCDONE=0 => RANGE OF CODES ENTERED
I $E(X,1,2)="-[" W $C(7)," ?? Not allowed" S APCD("NO DISPLAY")=1 G X2
I $E(X,$L(X))="*" D STAR G X2
I X'["-" S APCDTYP="LOW",APCDONE=1 D LOOK^APCDFOA4 G X2
I $E(X)="-",'$D(APCDTABL) W $C(7)," ?? No previous codes entered!" G X2
I $L(X,"-")>3 W $C(7)," ??" S APCDA=1 S APCD("NO DISPLAY")=1 G X2
I $L(X,"-")=3,$E(X,$L(X))="-" W $C(7)," ??" S APCDA=1 S APCD("NO DISPLAY")=1 G X2
I $L(X,"-")=3,$P(X,"-")]"" W $C(7)," ??" S APCDA=1 S APCD("NO DISPLAY")=1 G X2
I $E(X)="-" S APCDSUB=1 D I 1
. S APCDSAVE("X")=X
. I $L(X,"-")=3 S X=$P(APCDSAVE("X"),"-",2),APCDTYP="LOW" D LOOK^APCDFOA4 I 'APCDA S X=$P(APCDSAVE("X"),"-",3),APCDTYP="HI" W ! D LOOK^APCDFOA4 Q
. I $L(APCDSAVE("X"),"-")=2 S X=$E(X,2,99),APCDTYP="LOW",APCDONE=1 D LOOK^APCDFOA4
E S APCDSAVE("X")=X S APCDTYP="LOW",X=$P(APCDSAVE("X"),"-") D LOOK^APCDFOA4 I 'APCDA S APCDTYP="HI",X=$P(APCDSAVE("X"),"-",2) W ! D LOOK^APCDFOA4
X2 Q
;
DISPLAY ;EP - SHOW CODES IN RANGE SELECTED
W:$D(IOF) @IOF
NEW APCDX,APCDQ,APCDARR,X
;W !!,"ICD codes in this range =>",!! W $P(APCD("LOW")," ") S APCDDFN=$O(^ICD9("BA",APCD("LOW"),"")) W ?9,$P(^ICD9(APCDDFN,0),U,3) ;cmi/anch/maw 9/10/2007 orig line
W !!,"ICD Procedure codes in this range =>",!!
;call new API to get all codes back in APCDARR
D LST^ATXAPI(APCDSYS,80.1,$$STRIP^XLFSTR(APCD("LOW"))_"-"_$$STRIP^XLFSTR(APCD("HI")),"CODE","APCDARR")
S APCDX="",APCDQ=0 F S APCDX=$O(APCDARR(APCDX)) Q:APCDX=""!($G(APCDQ)) D
.I $Y>(IOSL-2) D EOP Q:APCDQ
.I $P(APCDARR(APCDX),U,2)=1 W !,APCDX,?12,$E($P($$ICDOP^ICDEX($P(APCDARR(APCDX),U,1),,,"I"),U,5),1,40),?60,$P(APCDARR(APCDX),U,4) I 1
.E W !,APCDX,?12,$E($P($$ICDOP^ICDEX($P(APCDARR(APCDX),U,1),,,"I"),U,5),1,40),?60,$P(APCDARR(APCDX),U,4)
NEW DIR
S DIR(0)="E",DIR("A")="Press Enter to Continue <>" D ^DIR
Q
EOP ;
S APCDQ=0
NEW DIR
K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
S DIR(0)="E" D ^DIR K DIR
I $D(DUOUT) S APCDQ=1 Q
W:$D(IOF) @IOF
Q
STAR ;
I $E(X)="-" S APCDSUB=1
NEW APCDTEMP
D LST^ATXAPI(APCDSYS,80.1,$S($E(X)="-":$E(X,2,999),1:X),"CODE","APCDTEMP")
I '$D(APCDTEMP) W " ?? There are no codes in that range!" S APCD("NO DISPLAY")=1 Q
S APCD("LOW")=$O(APCDTEMP(0))
NEW Z,C
S (Z,C)="" F S Z=$O(APCDTEMP(Z)) Q:Z="" S C=Z
S APCD("HI")=C
D DISPLAY
D ^APCDFOA5
;S APCDSAVE("X")=X S APCDTYP="LOW",X=APCD("LOW") D LOOK^APCDFOA4 I 'APCDA S APCDTYP="HI",X=APCD("HI") W ! D LOOK^APCDFOA4
Q
;
SETUTIL ;SET UP TMP NODES TO STORE CODES
NEW APCDX,APCDQ,APCDARR
S APCDIRNG=0,APCD("LOW")="" F S APCD("LOW")=$O(APCDTABL(APCD("LOW"))) Q:APCD("LOW")="" S APCD("HI")=$P(APCDTABL(APCD("LOW")),U,1) D
.S APCDIRNG=APCDIRNG+1
.KILL APCDX,APCDQ,APCDARR
.D LST^ATXAPI(APCDSYS,80.1,$$STRIP^XLFSTR(APCD("LOW"))_"-"_$$STRIP^XLFSTR(APCD("HI")),"CODE","APCDARR")
.S ^XTMP("APCDFOA",APCDJOB,APCDBT,APCDIRNG,"ICDB")=APCD("LOW")
.S ^XTMP("APCDFOA",APCDJOB,APCDBT,APCDIRNG,"ICDE")=APCD("HI")
.S APCDDFN=$$CODEABA^ICDEX(APCD("LOW"),80.1,APCDSYS),^XTMP("APCDFOA",APCDJOB,APCDBT,"DEPOV","ICDDFN",APCDDFN,APCDIRNG)=""
.S X="" F S X=$O(APCDARR(X)) Q:X="" D
..S ^XTMP("APCDFOA",APCDJOB,APCDBT,"DEPOV","ICDDFN",$P(APCDARR(X),U,1),APCDIRNG)=""
.Q
Q
RANGES ;DISPLAY TABLE OF ALL RANGES
W:$D(IOF) @IOF
W !!,"ICD Code Range(s) Selected So Far =>",!
S (APCD("NUM"),APCD)=0 F S APCD=$O(APCDTABL(APCD)) Q:APCD="" S APCD("NUM")=APCD("NUM")+1 W !,APCD("NUM"),") ",APCD,$S(APCD'=$P(APCDTABL(APCD),U,1):"- "_$P(APCDTABL(APCD),U,1),1:"")
I '$D(APCD("BANG")) W !
Q
;
SHOW ; ENTRY POINT - ALLOW USER TO SELECT FROM RANGES TO DISPLAY CODES
D RANGES
A W !,"Enter an Item Number from the table above to display code(s): " R APCD("N"):300 W:"^"[APCD("N") ! Q:"^"[APCD("N") I APCD("N")'?1N!(APCD("N")>APCD("NUM")) W " ??",$C(7) G A
F APCDI=1:1:APCD("N") S APCD=$O(APCDTABL(APCD)) I APCDI=APCD("N") S APCD("LOW")=APCD,APCD("HI")=$P(APCDTABL(APCD),U,1) D DISPLAY Q
S APCD("BANG")="" D RANGES K APCD("BANG")
Q
;
;
CHECK ;ASKS USER IF SATISFIED WITH ENTERED RANGES
W ! S DIR(0)="Y",DIR("B")="Y",DIR("A")="Are all of the ICD ranges okay" D ^DIR K DIR
W !
Q
;
EOJ ;
I $D(APCD("NOT TAX")) K APCDSTP,APCDX
K APCDSUB,APCDTYP,APCDDFN,DIR,APCDSAVE,APCDA,APCDCNT,APCD,APCDR,APCDI,APCDONE,APCDFLG
Q
;
APCDFOA3 ; IHS/CMI/LAB - USER INTERFACE TO SELECT ICD CODES ;
+1 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
BEGIN ;
+1 WRITE !
+2 SET APCD("NO DISPLAY")=0
+3 DO ASK1
+4 IF Y="^"
SET APCDSTP=1
GOTO X
+5 IF $DATA(APCDTABL)
DO CHECK
IF Y'=1
GOTO @$SELECT(Y=0:"BEGIN",1:"X")
X IF $DATA(APCDTABL)
DO SETUTIL
+1 DO EOJ
+2 QUIT
+3 ;
ASK1 ;
+1 SET APCDA=0
+2 ;WHAT CODING SYSTEM?
+3 SET APCDSYS=""
+4 WRITE !,"You must enter the coding system from which you want to enter a code,",!,"or range of codes.",!
+5 SET DIC="^ICDS("
SET DIC("S")="I $P(^(0),U,3)=80.1"
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
+6 IF Y=-1
GOTO X1
+7 SET APCDSYS=+Y
+8 KILL APCD("LOW"),APCD("HI")
+9 SET DIR("A")=$SELECT('$DATA(APCDTABL):"Enter Procedure (or range of procedure codes)",1:"Enter another Procedure (or range of procedure codes)")
DO SETDIR^APCDFOA4
DO ^DIR
KILL DIR
+10 IF "^"[Y
GOTO X1
+11 DO PROCESS
+12 IF $DATA(APCDTABL)
IF 'APCD("NO DISPLAY")
DO RANGES
+13 SET APCD("NO DISPLAY")=0
+14 GOTO ASK1
X1 QUIT
+1 ;
PROCESS ;EVALUATE USER RESPONSE
+1 ;APCDSUB=0 => NO DELETE OF CODE(S),APCDONE=0 => RANGE OF CODES ENTERED
SET (APCDSUB,APCDONE)=0
+2 IF $EXTRACT(X,1,2)="-["
WRITE $CHAR(7)," ?? Not allowed"
SET APCD("NO DISPLAY")=1
GOTO X2
+3 IF $EXTRACT(X,$LENGTH(X))="*"
DO STAR
GOTO X2
+4 IF X'["-"
SET APCDTYP="LOW"
SET APCDONE=1
DO LOOK^APCDFOA4
GOTO X2
+5 IF $EXTRACT(X)="-"
IF '$DATA(APCDTABL)
WRITE $CHAR(7)," ?? No previous codes entered!"
GOTO X2
+6 IF $LENGTH(X,"-")>3
WRITE $CHAR(7)," ??"
SET APCDA=1
SET APCD("NO DISPLAY")=1
GOTO X2
+7 IF $LENGTH(X,"-")=3
IF $EXTRACT(X,$LENGTH(X))="-"
WRITE $CHAR(7)," ??"
SET APCDA=1
SET APCD("NO DISPLAY")=1
GOTO X2
+8 IF $LENGTH(X,"-")=3
IF $PIECE(X,"-")]""
WRITE $CHAR(7)," ??"
SET APCDA=1
SET APCD("NO DISPLAY")=1
GOTO X2
+9 IF $EXTRACT(X)="-"
SET APCDSUB=1
Begin DoDot:1
+10 SET APCDSAVE("X")=X
+11 IF $LENGTH(X,"-")=3
SET X=$PIECE(APCDSAVE("X"),"-",2)
SET APCDTYP="LOW"
DO LOOK^APCDFOA4
IF 'APCDA
SET X=$PIECE(APCDSAVE("X"),"-",3)
SET APCDTYP="HI"
WRITE !
DO LOOK^APCDFOA4
QUIT
+12 IF $LENGTH(APCDSAVE("X"),"-")=2
SET X=$EXTRACT(X,2,99)
SET APCDTYP="LOW"
SET APCDONE=1
DO LOOK^APCDFOA4
End DoDot:1
IF 1
+13 IF '$TEST
SET APCDSAVE("X")=X
SET APCDTYP="LOW"
SET X=$PIECE(APCDSAVE("X"),"-")
DO LOOK^APCDFOA4
IF 'APCDA
SET APCDTYP="HI"
SET X=$PIECE(APCDSAVE("X"),"-",2)
WRITE !
DO LOOK^APCDFOA4
X2 QUIT
+1 ;
DISPLAY ;EP - SHOW CODES IN RANGE SELECTED
+1 IF $DATA(IOF)
WRITE @IOF
+2 NEW APCDX,APCDQ,APCDARR,X
+3 ;W !!,"ICD codes in this range =>",!! W $P(APCD("LOW")," ") S APCDDFN=$O(^ICD9("BA",APCD("LOW"),"")) W ?9,$P(^ICD9(APCDDFN,0),U,3) ;cmi/anch/maw 9/10/2007 orig line
+4 WRITE !!,"ICD Procedure codes in this range =>",!!
+5 ;call new API to get all codes back in APCDARR
+6 DO LST^ATXAPI(APCDSYS,80.1,$$STRIP^XLFSTR(APCD("LOW"))_"-"_$$STRIP^XLFSTR(APCD("HI")),"CODE","APCDARR")
+7 SET APCDX=""
SET APCDQ=0
FOR
SET APCDX=$ORDER(APCDARR(APCDX))
IF APCDX=""!($GET(APCDQ))
QUIT
Begin DoDot:1
+8 IF $Y>(IOSL-2)
DO EOP
IF APCDQ
QUIT
+9 IF $PIECE(APCDARR(APCDX),U,2)=1
WRITE !,APCDX,?12,$EXTRACT($PIECE($$ICDOP^ICDEX($PIECE(APCDARR(APCDX),U,1),,,"I"),U,5),1,40),?60,$PIECE(APCDARR(APCDX),U,4)
IF 1
+10 IF '$TEST
WRITE !,APCDX,?12,$EXTRACT($PIECE($$ICDOP^ICDEX($PIECE(APCDARR(APCDX),U,1),,,"I"),U,5),1,40),?60,$PIECE(APCDARR(APCDX),U,4)
End DoDot:1
+11 NEW DIR
+12 SET DIR(0)="E"
SET DIR("A")="Press Enter to Continue <>"
DO ^DIR
+13 QUIT
EOP ;
+1 SET APCDQ=0
+2 NEW DIR
+3 KILL DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
+4 SET DIR(0)="E"
DO ^DIR
KILL DIR
+5 IF $DATA(DUOUT)
SET APCDQ=1
QUIT
+6 IF $DATA(IOF)
WRITE @IOF
+7 QUIT
STAR ;
+1 IF $EXTRACT(X)="-"
SET APCDSUB=1
+2 NEW APCDTEMP
+3 DO LST^ATXAPI(APCDSYS,80.1,$SELECT($EXTRACT(X)="-":$EXTRACT(X,2,999),1:X),"CODE","APCDTEMP")
+4 IF '$DATA(APCDTEMP)
WRITE " ?? There are no codes in that range!"
SET APCD("NO DISPLAY")=1
QUIT
+5 SET APCD("LOW")=$ORDER(APCDTEMP(0))
+6 NEW Z,C
+7 SET (Z,C)=""
FOR
SET Z=$ORDER(APCDTEMP(Z))
IF Z=""
QUIT
SET C=Z
+8 SET APCD("HI")=C
+9 DO DISPLAY
+10 DO ^APCDFOA5
+11 ;S APCDSAVE("X")=X S APCDTYP="LOW",X=APCD("LOW") D LOOK^APCDFOA4 I 'APCDA S APCDTYP="HI",X=APCD("HI") W ! D LOOK^APCDFOA4
+12 QUIT
+13 ;
SETUTIL ;SET UP TMP NODES TO STORE CODES
+1 NEW APCDX,APCDQ,APCDARR
+2 SET APCDIRNG=0
SET APCD("LOW")=""
FOR
SET APCD("LOW")=$ORDER(APCDTABL(APCD("LOW")))
IF APCD("LOW")=""
QUIT
SET APCD("HI")=$PIECE(APCDTABL(APCD("LOW")),U,1)
Begin DoDot:1
+3 SET APCDIRNG=APCDIRNG+1
+4 KILL APCDX,APCDQ,APCDARR
+5 DO LST^ATXAPI(APCDSYS,80.1,$$STRIP^XLFSTR(APCD("LOW"))_"-"_$$STRIP^XLFSTR(APCD("HI")),"CODE","APCDARR")
+6 SET ^XTMP("APCDFOA",APCDJOB,APCDBT,APCDIRNG,"ICDB")=APCD("LOW")
+7 SET ^XTMP("APCDFOA",APCDJOB,APCDBT,APCDIRNG,"ICDE")=APCD("HI")
+8 SET APCDDFN=$$CODEABA^ICDEX(APCD("LOW"),80.1,APCDSYS)
SET ^XTMP("APCDFOA",APCDJOB,APCDBT,"DEPOV","ICDDFN",APCDDFN,APCDIRNG)=""
+9 SET X=""
FOR
SET X=$ORDER(APCDARR(X))
IF X=""
QUIT
Begin DoDot:2
+10 SET ^XTMP("APCDFOA",APCDJOB,APCDBT,"DEPOV","ICDDFN",$PIECE(APCDARR(X),U,1),APCDIRNG)=""
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT
RANGES ;DISPLAY TABLE OF ALL RANGES
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !!,"ICD Code Range(s) Selected So Far =>",!
+3 SET (APCD("NUM"),APCD)=0
FOR
SET APCD=$ORDER(APCDTABL(APCD))
IF APCD=""
QUIT
SET APCD("NUM")=APCD("NUM")+1
WRITE !,APCD("NUM"),") ",APCD,$SELECT(APCD'=$PIECE(APCDTABL(APCD),U,1):"- "_$PIECE(APCDTABL(APCD),U,1),1:"")
+4 IF '$DATA(APCD("BANG"))
WRITE !
+5 QUIT
+6 ;
SHOW ; ENTRY POINT - ALLOW USER TO SELECT FROM RANGES TO DISPLAY CODES
+1 DO RANGES
A WRITE !,"Enter an Item Number from the table above to display code(s): "
READ APCD("N"):300
IF "^"[APCD("N")
WRITE !
IF "^"[APCD("N")
QUIT
IF APCD("N")'?1N!(APCD("N")>APCD("NUM"))
WRITE " ??",$CHAR(7)
GOTO A
+1 FOR APCDI=1:1:APCD("N")
SET APCD=$ORDER(APCDTABL(APCD))
IF APCDI=APCD("N")
SET APCD("LOW")=APCD
SET APCD("HI")=$PIECE(APCDTABL(APCD),U,1)
DO DISPLAY
QUIT
+2 SET APCD("BANG")=""
DO RANGES
KILL APCD("BANG")
+3 QUIT
+4 ;
+5 ;
CHECK ;ASKS USER IF SATISFIED WITH ENTERED RANGES
+1 WRITE !
SET DIR(0)="Y"
SET DIR("B")="Y"
SET DIR("A")="Are all of the ICD ranges okay"
DO ^DIR
KILL DIR
+2 WRITE !
+3 QUIT
+4 ;
EOJ ;
+1 IF $DATA(APCD("NOT TAX"))
KILL APCDSTP,APCDX
+2 KILL APCDSUB,APCDTYP,APCDDFN,DIR,APCDSAVE,APCDA,APCDCNT,APCD,APCDR,APCDI,APCDONE,APCDFLG
+3 QUIT
+4 ;
