APCLAUD5 ; IHS/CMI/LAB - USER INTERFACE TO SELECT ICD CODES ;
;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
;
;cmi/anch/maw 9/10/2007 code set versioning in DISPLAY
BEGIN ;
W !
S APCL("NO DISPLAY")=0
D ASK1
I Y="^" S APCLSTP=1 G X
I $D(APCLTABL) D CHECK I Y'=1 G @$S(Y=0:"BEGIN",1:"X")
X I $D(APCLTABL) D SETUTIL
D EOJ
Q
;
ASK1 ;
;WHAT CODING SYSTEM?
S APCLSYS="",APCLA=0
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",DIC(0)="AEMQ" D ^DIC K DIC
I Y=-1 G X1
S APCLSYS=+Y
K APCL("LOW"),APCL("HI")
S DIR("A")=$S('$D(APCLTABL):"Enter Diagnosis (or range of DX codes)",1:"Enter Another Diagnosis (or range of DX codes)") D SETDIR^APCLAUD6,^DIR K DIR
I "^"[Y G X1
D PROCESS
I $D(APCLTABL),'APCL("NO DISPLAY") D RANGES
S APCL("NO DISPLAY")=0
G ASK1
X1 Q
;
PROCESS ;EVALUATE USER RESPONSE
S (APCLSUB,APCLONE)=0 ;APCLSUB=0 => NO DELETE OF CODE(S),APCLONE=0 => RANGE OF CODES ENTERED
I $E(X,1,2)="-[" W $C(7)," ?? Not allowed" S APCL("NO DISPLAY")=1 G X2
I $E(X,$L(X))="*" D STAR G X2
I X'["-" S APCLTYP="LOW",APCLONE=1 D LOOK^APCLAUD6 G X2
I $E(X)="-",'$D(APCLTABL) W $C(7)," ?? No previous codes entered!" G X2
I $L(X,"-")>3 W $C(7)," ??" S APCLA=1 S APCL("NO DISPLAY")=1 G X2
I $L(X,"-")=3,$E(X,$L(X))="-" W $C(7)," ??" S APCLA=1 S APCL("NO DISPLAY")=1 G X2
I $L(X,"-")=3,$P(X,"-")]"" W $C(7)," ??" S APCLA=1 S APCL("NO DISPLAY")=1 G X2
I $E(X)="-" S APCLSUB=1 D I 1
. S APCLSAVE("X")=X
. I $L(X,"-")=3 S X=$P(APCLSAVE("X"),"-",2),APCLTYP="LOW" D LOOK^APCLAUD6 I 'APCLA S X=$P(APCLSAVE("X"),"-",3),APCLTYP="HI" W ! D LOOK^APCLAUD6 Q
. I $L(APCLSAVE("X"),"-")=2 S X=$E(X,2,99),APCLTYP="LOW",APCLONE=1 D LOOK^APCLAUD6
E S APCLSAVE("X")=X S APCLTYP="LOW",X=$P(APCLSAVE("X"),"-") D LOOK^APCLAUD6 I 'APCLA S APCLTYP="HI",X=$P(APCLSAVE("X"),"-",2) W ! D LOOK^APCLAUD6
X2 Q
;
DISPLAY ;EP - SHOW CODES IN RANGE SELECTED
W:$D(IOF) @IOF
NEW APCLX,APCLQ,APCLARR,X
;W !!,"ICD codes in this range =>",!! W $P(APCL("LOW")," ") S APCLDFN=$O(^ICD9("BA",APCL("LOW"),"")) W ?9,$P(^ICD9(APCLDFN,0),U,3) ;cmi/anch/maw 9/10/2007 orig line
W !!,"ICD codes in this range =>",!!
;call new API to get all codes back in APCLARR
D LST^ATXAPI(APCLSYS,80,$$STRIP^XLFSTR(APCL("LOW"))_"-"_$$STRIP^XLFSTR(APCL("HI")),"CODE","APCLARR")
S APCLX="",APCLQ=0 F S APCLX=$O(APCLARR(APCLX)) Q:APCLX=""!($G(APCLQ)) D
.I $Y>(IOSL-2) D EOP Q:APCLQ
.I $P(APCLARR(APCLX),U,2)=1 W !,APCLX,?12,$E($P($$ICDDX^ICDEX($P(APCLARR(APCLX),U,1)),U,4),1,40),?60,$P(APCLARR(APCLX),U,4) I 1
.E W !,APCLX,?12,$E($P($$ICDDX^ICDEX($P(APCLARR(APCLX),U,1)),U,4),1,40),?60,$P(APCLARR(APCLX),U,4)
NEW DIR
S DIR(0)="E",DIR("A")="Press Enter to Continue <>" D ^DIR
Q
EOP ;
S APCLQ=0
NEW DIR
K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
S DIR(0)="E" D ^DIR K DIR
I $D(DUOUT) S APCLQ=1 Q
W:$D(IOF) @IOF
Q
;
SETUTIL ;SET UP UTILITY NODES TO STORE CODES
NEW APCLX,APCLQ,APCLARR
S APCLIRNG=0,APCL("LOW")="" F S APCL("LOW")=$O(APCLTABL(APCL("LOW"))) Q:APCL("LOW")="" S APCL("HI")=$P(APCLTABL(APCL("LOW")),U,1) D
.S APCLIRNG=APCLIRNG+1
.KILL APCLX,APCLQ,APCLARR
.D LST^ATXAPI(APCLSYS,80,$$STRIP^XLFSTR(APCL("LOW"))_"-"_$$STRIP^XLFSTR(APCL("HI")),"CODE","APCLARR")
.S ^XTMP("APCLAUD",APCLJOB,APCLBT,APCLIRNG,"ICDB")=APCL("LOW")
.S ^XTMP("APCLAUD",APCLJOB,APCLBT,APCLIRNG,"ICDE")=APCL("HI")
.;S APCLDFN=$$CODEN^ICDEX(APCL("LOW")),^XTMP("APCLAUD",APCLJOB,APCLBT,"ICDDFN",APCLDFN,APCLIRNG)=""
.S X="" F S X=$O(APCLARR(X)) Q:X="" D
..S ^XTMP("APCLAUD",APCLJOB,APCLBT,"ICDDFN",$P(APCLARR(X),U,1),APCLIRNG)=""
.Q
Q
RANGES ;DISPLAY TABLE OF ALL RANGES
W:$D(IOF) @IOF
W !!,"ICD Code Range(s) Selected So Far =>",!
S (APCL("NUM"),APCL)=0 F S APCL=$O(APCLTABL(APCL)) Q:APCL="" S APCL("NUM")=APCL("NUM")+1 W !,APCL("NUM"),") ",APCL,$S(APCL'=$P(APCLTABL(APCL),U,1):"- "_$P(APCLTABL(APCL),U,1),1:"")
I '$D(APCL("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 APCL("N"):300 W:"^"[APCL("N") ! Q:"^"[APCL("N") I APCL("N")'?1N!(APCL("N")>APCL("NUM")) W " ??",$C(7) G A
F APCLI=1:1:APCL("N") S APCL=$O(APCLTABL(APCL)) I APCLI=APCL("N") S APCL("LOW")=APCL,APCL("HI")=$P(APCLTABL(APCL),U,1) D DISPLAY Q
S APCL("BANG")="" D RANGES K APCL("BANG")
Q
;
;
CHECK ;ASKS USER IF SATISFIED WITH ENTERED RANGES
NEW DIR
W ! S DIR(0)="Y",DIR("B")="Y",DIR("A")="Are all of the ICD ranges okay" D ^DIR K DIR
W !
Q
;
EOJ ;ENTRY POINT
I $D(APCL("NOT TAX")) K APCLSTP,APCLX
K APCLSUB,APCLTYP,APCLDFN,DIR,APCLSAVE,APCLA,APCLCNT,APCL,APCLR,APCLI,APCLONE,APCLFLG
Q
;
STAR ;
I $E(X)="-" S APCLSUB=1
NEW APCLTEMP
D LST^ATXAPI(APCLSYS,80,$S($E(X)="-":$E(X,2,999),1:X),"CODE","APCLTEMP")
I '$D(APCLTEMP) W " ?? There are no codes in that range!" S APCL("NO DISPLAY")=1 Q
S APCL("LOW")=$O(APCLTEMP(0))
NEW Z,C
S (Z,C)="" F S Z=$O(APCLTEMP(Z)) Q:Z="" S C=Z
S APCL("HI")=C
D DISPLAY
D ^APCLAUD7
Q
APCLAUD5 ; IHS/CMI/LAB - USER INTERFACE TO SELECT ICD CODES ;
+1 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
+2 ;
+3 ;cmi/anch/maw 9/10/2007 code set versioning in DISPLAY
BEGIN ;
+1 WRITE !
+2 SET APCL("NO DISPLAY")=0
+3 DO ASK1
+4 IF Y="^"
SET APCLSTP=1
GOTO X
+5 IF $DATA(APCLTABL)
DO CHECK
IF Y'=1
GOTO @$SELECT(Y=0:"BEGIN",1:"X")
X IF $DATA(APCLTABL)
DO SETUTIL
+1 DO EOJ
+2 QUIT
+3 ;
ASK1 ;
+1 ;WHAT CODING SYSTEM?
+2 SET APCLSYS=""
SET APCLA=0
+3 WRITE !,"You must enter the coding system from which you want to enter a code,",!,"or range of codes.",!
+4 SET DIC="^ICDS("
SET DIC("S")="I $P(^(0),U,3)=80"
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
+5 IF Y=-1
GOTO X1
+6 SET APCLSYS=+Y
+7 KILL APCL("LOW"),APCL("HI")
+8 SET DIR("A")=$SELECT('$DATA(APCLTABL):"Enter Diagnosis (or range of DX codes)",1:"Enter Another Diagnosis (or range of DX codes)")
DO SETDIR^APCLAUD6
DO ^DIR
KILL DIR
+9 IF "^"[Y
GOTO X1
+10 DO PROCESS
+11 IF $DATA(APCLTABL)
IF 'APCL("NO DISPLAY")
DO RANGES
+12 SET APCL("NO DISPLAY")=0
+13 GOTO ASK1
X1 QUIT
+1 ;
PROCESS ;EVALUATE USER RESPONSE
+1 ;APCLSUB=0 => NO DELETE OF CODE(S),APCLONE=0 => RANGE OF CODES ENTERED
SET (APCLSUB,APCLONE)=0
+2 IF $EXTRACT(X,1,2)="-["
WRITE $CHAR(7)," ?? Not allowed"
SET APCL("NO DISPLAY")=1
GOTO X2
+3 IF $EXTRACT(X,$LENGTH(X))="*"
DO STAR
GOTO X2
+4 IF X'["-"
SET APCLTYP="LOW"
SET APCLONE=1
DO LOOK^APCLAUD6
GOTO X2
+5 IF $EXTRACT(X)="-"
IF '$DATA(APCLTABL)
WRITE $CHAR(7)," ?? No previous codes entered!"
GOTO X2
+6 IF $LENGTH(X,"-")>3
WRITE $CHAR(7)," ??"
SET APCLA=1
SET APCL("NO DISPLAY")=1
GOTO X2
+7 IF $LENGTH(X,"-")=3
IF $EXTRACT(X,$LENGTH(X))="-"
WRITE $CHAR(7)," ??"
SET APCLA=1
SET APCL("NO DISPLAY")=1
GOTO X2
+8 IF $LENGTH(X,"-")=3
IF $PIECE(X,"-")]""
WRITE $CHAR(7)," ??"
SET APCLA=1
SET APCL("NO DISPLAY")=1
GOTO X2
+9 IF $EXTRACT(X)="-"
SET APCLSUB=1
Begin DoDot:1
+10 SET APCLSAVE("X")=X
+11 IF $LENGTH(X,"-")=3
SET X=$PIECE(APCLSAVE("X"),"-",2)
SET APCLTYP="LOW"
DO LOOK^APCLAUD6
IF 'APCLA
SET X=$PIECE(APCLSAVE("X"),"-",3)
SET APCLTYP="HI"
WRITE !
DO LOOK^APCLAUD6
QUIT
+12 IF $LENGTH(APCLSAVE("X"),"-")=2
SET X=$EXTRACT(X,2,99)
SET APCLTYP="LOW"
SET APCLONE=1
DO LOOK^APCLAUD6
End DoDot:1
IF 1
+13 IF '$TEST
SET APCLSAVE("X")=X
SET APCLTYP="LOW"
SET X=$PIECE(APCLSAVE("X"),"-")
DO LOOK^APCLAUD6
IF 'APCLA
SET APCLTYP="HI"
SET X=$PIECE(APCLSAVE("X"),"-",2)
WRITE !
DO LOOK^APCLAUD6
X2 QUIT
+1 ;
DISPLAY ;EP - SHOW CODES IN RANGE SELECTED
+1 IF $DATA(IOF)
WRITE @IOF
+2 NEW APCLX,APCLQ,APCLARR,X
+3 ;W !!,"ICD codes in this range =>",!! W $P(APCL("LOW")," ") S APCLDFN=$O(^ICD9("BA",APCL("LOW"),"")) W ?9,$P(^ICD9(APCLDFN,0),U,3) ;cmi/anch/maw 9/10/2007 orig line
+4 WRITE !!,"ICD codes in this range =>",!!
+5 ;call new API to get all codes back in APCLARR
+6 DO LST^ATXAPI(APCLSYS,80,$$STRIP^XLFSTR(APCL("LOW"))_"-"_$$STRIP^XLFSTR(APCL("HI")),"CODE","APCLARR")
+7 SET APCLX=""
SET APCLQ=0
FOR
SET APCLX=$ORDER(APCLARR(APCLX))
IF APCLX=""!($GET(APCLQ))
QUIT
Begin DoDot:1
+8 IF $Y>(IOSL-2)
DO EOP
IF APCLQ
QUIT
+9 IF $PIECE(APCLARR(APCLX),U,2)=1
WRITE !,APCLX,?12,$EXTRACT($PIECE($$ICDDX^ICDEX($PIECE(APCLARR(APCLX),U,1)),U,4),1,40),?60,$PIECE(APCLARR(APCLX),U,4)
IF 1
+10 IF '$TEST
WRITE !,APCLX,?12,$EXTRACT($PIECE($$ICDDX^ICDEX($PIECE(APCLARR(APCLX),U,1)),U,4),1,40),?60,$PIECE(APCLARR(APCLX),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 APCLQ=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 APCLQ=1
QUIT
+6 IF $DATA(IOF)
WRITE @IOF
+7 QUIT
+8 ;
SETUTIL ;SET UP UTILITY NODES TO STORE CODES
+1 NEW APCLX,APCLQ,APCLARR
+2 SET APCLIRNG=0
SET APCL("LOW")=""
FOR
SET APCL("LOW")=$ORDER(APCLTABL(APCL("LOW")))
IF APCL("LOW")=""
QUIT
SET APCL("HI")=$PIECE(APCLTABL(APCL("LOW")),U,1)
Begin DoDot:1
+3 SET APCLIRNG=APCLIRNG+1
+4 KILL APCLX,APCLQ,APCLARR
+5 DO LST^ATXAPI(APCLSYS,80,$$STRIP^XLFSTR(APCL("LOW"))_"-"_$$STRIP^XLFSTR(APCL("HI")),"CODE","APCLARR")
+6 SET ^XTMP("APCLAUD",APCLJOB,APCLBT,APCLIRNG,"ICDB")=APCL("LOW")
+7 SET ^XTMP("APCLAUD",APCLJOB,APCLBT,APCLIRNG,"ICDE")=APCL("HI")
+8 ;S APCLDFN=$$CODEN^ICDEX(APCL("LOW")),^XTMP("APCLAUD",APCLJOB,APCLBT,"ICDDFN",APCLDFN,APCLIRNG)=""
+9 SET X=""
FOR
SET X=$ORDER(APCLARR(X))
IF X=""
QUIT
Begin DoDot:2
+10 SET ^XTMP("APCLAUD",APCLJOB,APCLBT,"ICDDFN",$PIECE(APCLARR(X),U,1),APCLIRNG)=""
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 (APCL("NUM"),APCL)=0
FOR
SET APCL=$ORDER(APCLTABL(APCL))
IF APCL=""
QUIT
SET APCL("NUM")=APCL("NUM")+1
WRITE !,APCL("NUM"),") ",APCL,$SELECT(APCL'=$PIECE(APCLTABL(APCL),U,1):"- "_$PIECE(APCLTABL(APCL),U,1),1:"")
+4 IF '$DATA(APCL("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 APCL("N"):300
IF "^"[APCL("N")
WRITE !
IF "^"[APCL("N")
QUIT
IF APCL("N")'?1N!(APCL("N")>APCL("NUM"))
WRITE " ??",$CHAR(7)
GOTO A
+1 FOR APCLI=1:1:APCL("N")
SET APCL=$ORDER(APCLTABL(APCL))
IF APCLI=APCL("N")
SET APCL("LOW")=APCL
SET APCL("HI")=$PIECE(APCLTABL(APCL),U,1)
DO DISPLAY
QUIT
+2 SET APCL("BANG")=""
DO RANGES
KILL APCL("BANG")
+3 QUIT
+4 ;
+5 ;
CHECK ;ASKS USER IF SATISFIED WITH ENTERED RANGES
+1 NEW DIR
+2 WRITE !
SET DIR(0)="Y"
SET DIR("B")="Y"
SET DIR("A")="Are all of the ICD ranges okay"
DO ^DIR
KILL DIR
+3 WRITE !
+4 QUIT
+5 ;
EOJ ;ENTRY POINT
+1 IF $DATA(APCL("NOT TAX"))
KILL APCLSTP,APCLX
+2 KILL APCLSUB,APCLTYP,APCLDFN,DIR,APCLSAVE,APCLA,APCLCNT,APCL,APCLR,APCLI,APCLONE,APCLFLG
+3 QUIT
+4 ;
STAR ;
+1 IF $EXTRACT(X)="-"
SET APCLSUB=1
+2 NEW APCLTEMP
+3 DO LST^ATXAPI(APCLSYS,80,$SELECT($EXTRACT(X)="-":$EXTRACT(X,2,999),1:X),"CODE","APCLTEMP")
+4 IF '$DATA(APCLTEMP)
WRITE " ?? There are no codes in that range!"
SET APCL("NO DISPLAY")=1
QUIT
+5 SET APCL("LOW")=$ORDER(APCLTEMP(0))
+6 NEW Z,C
+7 SET (Z,C)=""
FOR
SET Z=$ORDER(APCLTEMP(Z))
IF Z=""
QUIT
SET C=Z
+8 SET APCL("HI")=C
+9 DO DISPLAY
+10 DO ^APCLAUD7
+11 QUIT
