APCHTAXM ; IHS/CMI/LAB - INTERFACE TO SELECT ICD CODES ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;
;cmi/anch/maw 8/28/2007 code set versioning in DISPLAY
;
D INIT
BEGIN D ASK1
I Y="^" S APCHSTP=1 G X
I $D(APCHTBLE) D CHECK I Y'=1 G @$S(Y=0:"BEGIN",1:"X")
X D EOJ
Q
;
INIT ;
S APCH("NO DISPLAY")=0
I $D(APCHX) D I 1
. I $D(APCHTBLE) S APCH("MODIFY")=1 D RANGES I 1
. E S APCH("ENTER")=1
E S APCH("NOT TAX")=""
Q
;
ASK1 ;
S APCHA=0
K APCH("LOW"),APCH("HI")
S DIR("A")=$S('$D(APCHTBLE):"ENTER CPT",1:"ENTER ANOTHER CPT") D SETDIR,^DIR K DIR
I "^"[Y G X1
D PROCESS
I $D(APCHTBLE),'APCH("NO DISPLAY") D RANGES
S APCH("NO DISPLAY")=0
G ASK1
X1 Q
;
PROCESS ;EVALUATE USER RESPONSE
S (APCHSUB,APCHONE)=0 ;APCHSUB=0 => NO DELETE OF CODE(S),APCHONE=0 => RANGE OF CODES ENTERED
I $E(X,1,2)="-[" W $C(7)," ?? Not allowed" S APCH("NO DISPLAY")=1 G X2
I $E(X)="[" D TAX G X2
I X'["-" S APCHTYP="LOW",APCHONE=1 D LOOK G X2
I $E(X)="-",'$D(APCHTBLE) W $C(7)," ?? No previous codes entered!" G X2
I $L(X,"-")>3 W $C(7)," ??" S APCHA=1 S APCH("NO DISPLAY")=1 G X2
I $L(X,"-")=3,$E(X,$L(X))="-" W $C(7)," ??" S APCHA=1 S APCH("NO DISPLAY")=1 G X2
I $L(X,"-")=3,$P(X,"-")]"" W $C(7)," ??" S APCHA=1 S APCH("NO DISPLAY")=1 G X2
I $E(X)="-" S APCHSUB=1 D I 1
. S APCHSAVE("X")=X
. I $L(X,"-")=3 S X=$P(APCHSAVE("X"),"-",2),APCHTYP="LOW" D LOOK I 'APCHA S X=$P(APCHSAVE("X"),"-",3),APCHTYP="HI" W ! D LOOK Q
. I $L(APCHSAVE("X"),"-")=2 S X=$E(X,2,99),APCHTYP="LOW",APCHONE=1 D LOOK
E S APCHSAVE("X")=X S APCHTYP="LOW",X=$P(APCHSAVE("X"),"-") D LOOK I 'APCHA S APCHTYP="HI",X=$P(APCHSAVE("X"),"-",2) W ! D LOOK
X2 Q
;
DISPLAY ;EP - SHOW CODES IN RANGE SELECTED
W:$D(IOF) @IOF
;W !!,"CPT codes in this range =>",!! W $P(APCH("LOW")," ") S APCHDFN=$O(^ICPT("BA",APCH("LOW"),"")) W ?9,$P(^ICPT(APCHDFN,0),U,2) ;cmi/anch/maw 8/28/2007 orig line
W !!,"CPT codes in this range =>",!! W $P(APCH("LOW")," ") S APCHDFN=$O(^ICPT("BA",APCH("LOW"),"")) W ?9,$P($$CPT^ICPTCOD(APCHDFN),U,3) ;cmi/anch/maw 8/28/2007 code set versioning
;S APCH=APCH("LOW"),APCHCNT=IOSL-2 F S APCH=$O(^ICPT("BA",APCH)) Q:APCH]APCH("HI") S APCHDFN=$O(^(APCH,"")) W !,$P(APCH," "),?9,$P(^ICPT(APCHDFN,0),U,2) S APCHCNT=APCHCNT-1 I APCHCNT=0 S APCHCNT=IOSL-2 D I APCHR=U Q
; ;cmi/anch/maw 8/28/2007 orig line
S APCH=APCH("LOW"),APCHCNT=IOSL-2
F S APCH=$O(^ICPT("BA",APCH)) Q:APCH]APCH("HI") S APCHDFN=$O(^(APCH,"")) W !,$P(APCH," "),?9,$P($$CPT^ICPTCOD(APCHDFN),U,3) S APCHCNT=APCHCNT-1 I APCHCNT=0 S APCHCNT=IOSL-2 D I APCHR=U Q ;cmi/anch/maw 8/28/2007 code set versioning
A1 . R !,"<>",APCHR:DTIME W:APCHR["?" " Enter ""^"" to stop display, return to continue" G:APCHR["?" A1
I $S('$D(APCHR):1,APCHR'=U:1,1:0) R !!,"Press return to continue",APCHR:DTIME
W !
K APCHR Q
;
RANGES ;DISPLAY TABLE OF ALL RANGES
W:$D(IOF) @IOF
W !!,"CPT Code Range(s) Selected So Far =>",!
S (APCH("NUM"),APCH)=0 F S APCH=$O(APCHTBLE(APCH)) Q:APCH="" S APCH("NUM")=APCH("NUM")+1 W !,APCH("NUM"),") ",APCH,$S(APCH'=APCHTBLE(APCH):"- "_APCHTBLE(APCH),1:"")
I '$D(APCH("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 APCH("N"):300 W:"^"[APCH("N") ! Q:"^"[APCH("N") I APCH("N")'?1N!(APCH("N")>APCH("NUM")) W " ??",$C(7) G A
F APCHI=1:1:APCH("N") S APCH=$O(APCHTBLE(APCH)) I APCHI=APCH("N") S APCH("LOW")=APCH,APCH("HI")=APCHTBLE(APCH) D DISPLAY Q
S APCH("BANG")="" D RANGES K APCH("BANG")
Q
;
TAX ;PLACE CODES FROM SELECTED TAXONOMY IN APCHTBLE
S APCH("S")="I Y'=APCHX",APCH("S")=$S($D(APCHX):APCH("S")_",$O(^ATXAX(Y,21,0))",1:"I $O(^(21,0))"),DIC("A")="TAXONOMY FROM WHICH TO SELECT CODES: ",APCH("S")=APCH("S")_$S('$D(APCHX):"",1:",$P(^ATXAX(APCHX,0),U,15)=$P(^ATXAX(Y,0),U,15)")
I $E(X,2)="?" S X="?",DIC="^ATXAX(",DIC(0)="EM",DIC("S")=APCH("S") D ^DIC S DIC(0)="AEMQ",DIC("S")=APCH("S"),DIC="^ATXAX(" D ^DIC K DIC I 1
E S X=$E(X,2,99),DIC(0)="EMQ",DIC("S")=APCH("S"),DIC="^ATXAX(" D ^DIC K DIC
I Y=-1 G X3
S APCH("CODE")=0 F S APCH("CODE")=$O(^ATXAX(+Y,21,"AA",APCH("CODE"))) Q:APCH("CODE")="" S APCHTBLE(APCH("CODE"))=$O(^(APCH("CODE"),""))
X3 W ! Q
;
CHECK ;ASKS USER IF SATISFIED WITH ENTERED RANGES
W ! S DIR(0)="Y",DIR("B")="Y",DIR("A")="Is everything okay" D ^DIR K DIR
W !
Q
;
EOJ ;
K APCHSUB,APCHTYP,APCHDFN,DIR,APCHSAVE,APCHA,APCHCNT,APCH,APCHR,APCHI,APCHONE,APCHFLG,APCHSTP
Q
;
SETDIR ; ENTRY POINT - SETS HELP AND DIR FOR INIT SUBROUTINE OF APCHCODE
S DIR(0)="FO",DIR("?",1)="Enter cpt code or narrative. You may enter a range of",DIR("?",2)="codes by placing a ""-"" between two codes. Codes in a range will"
S DIR("?",3)="include the first and last codes indicated and all codes that fall",DIR("?",4)="between. Only one code or one range of codes at a time. You may"
S DIR("?",5)="also enter ""[TAXONOMY NAME"" to select codes already within a taxonomy."
S DIR("?",6)="You can also ""de-select"" a code or range of codes by placing a ""-"" in",DIR("?",7)="front of it. (e.g. '-250.00' or '-250.01-250.91') Enter ""??"" to see"
S DIR("?")="code ranges selected so far."
S DIR("??")="^D ASK2"
Q
;
LOOK ; ENTRY POINT - LOOKUP USER RESPONSE; SET UTILITY NODES
S DIC="^ICPT(",DIC(0)="EMF" D ^DIC K DIC,DR
I Y<0 S APCHA=1 W $C(7)," ??" S APCH("NO DISPLAY")=1 G X5
S:APCHTYP="LOW" APCH("LOW")=$P(^ICPT(+Y,0),U)_" "
I APCHTYP="LOW",APCHONE S APCH("HI")=APCH("LOW") D ^APCHTAXN
I APCHTYP="HI" S APCH("HI")=$P(^ICPT(+Y,0),U)_" " D I 'APCH("NO DISPLAY") D DISPLAY^APCHTAXM,^APCHTAXN
. I $E(APCH("HI"))?1N&($E(APCH("LOW"))?1N)!($E(APCH("LOW"))'?1N&($E(APCH("HI"))'?1N))
. E W !,$C(7),"Low and high codes of range must both start either with a letter or a number.",! S APCH("NO DISPLAY")=1
. I 'APCH("NO DISPLAY") I APCH("LOW")]APCH("HI") W !,$C(7),"Low code is higher than high code.",! S APCH("NO DISPLAY")=1
X5 Q
;
ASK2 ;ASKS USER IF WANTS TO DISPLAY/PRINT RESULTS TO THIS POINT
I '$D(APCHTBLE) W !!,"A code range has yet to be selected. A display cannot be generated.",! Q
W !!,"Do you want to display the codes from a range you have already selected" S %=1 D YN^DICN I %=1 D SHOW^APCHTAXM
I %=2!(%=-1) Q
I %=0 W !!,"A table of ranges you have selected is displayed above. You may ask for the",!,"codes in one of the ranges to be displayed.",! G ASK2
Q
;
APCHTAXM ; IHS/CMI/LAB - INTERFACE TO SELECT ICD CODES ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;
+3 ;cmi/anch/maw 8/28/2007 code set versioning in DISPLAY
+4 ;
+5 DO INIT
BEGIN DO ASK1
+1 IF Y="^"
SET APCHSTP=1
GOTO X
+2 IF $DATA(APCHTBLE)
DO CHECK
IF Y'=1
GOTO @$SELECT(Y=0:"BEGIN",1:"X")
X DO EOJ
+1 QUIT
+2 ;
INIT ;
+1 SET APCH("NO DISPLAY")=0
+2 IF $DATA(APCHX)
Begin DoDot:1
+3 IF $DATA(APCHTBLE)
SET APCH("MODIFY")=1
DO RANGES
IF 1
+4 IF '$TEST
SET APCH("ENTER")=1
End DoDot:1
IF 1
+5 IF '$TEST
SET APCH("NOT TAX")=""
+6 QUIT
+7 ;
ASK1 ;
+1 SET APCHA=0
+2 KILL APCH("LOW"),APCH("HI")
+3 SET DIR("A")=$SELECT('$DATA(APCHTBLE):"ENTER CPT",1:"ENTER ANOTHER CPT")
DO SETDIR
DO ^DIR
KILL DIR
+4 IF "^"[Y
GOTO X1
+5 DO PROCESS
+6 IF $DATA(APCHTBLE)
IF 'APCH("NO DISPLAY")
DO RANGES
+7 SET APCH("NO DISPLAY")=0
+8 GOTO ASK1
X1 QUIT
+1 ;
PROCESS ;EVALUATE USER RESPONSE
+1 ;APCHSUB=0 => NO DELETE OF CODE(S),APCHONE=0 => RANGE OF CODES ENTERED
SET (APCHSUB,APCHONE)=0
+2 IF $EXTRACT(X,1,2)="-["
WRITE $CHAR(7)," ?? Not allowed"
SET APCH("NO DISPLAY")=1
GOTO X2
+3 IF $EXTRACT(X)="["
DO TAX
GOTO X2
+4 IF X'["-"
SET APCHTYP="LOW"
SET APCHONE=1
DO LOOK
GOTO X2
+5 IF $EXTRACT(X)="-"
IF '$DATA(APCHTBLE)
WRITE $CHAR(7)," ?? No previous codes entered!"
GOTO X2
+6 IF $LENGTH(X,"-")>3
WRITE $CHAR(7)," ??"
SET APCHA=1
SET APCH("NO DISPLAY")=1
GOTO X2
+7 IF $LENGTH(X,"-")=3
IF $EXTRACT(X,$LENGTH(X))="-"
WRITE $CHAR(7)," ??"
SET APCHA=1
SET APCH("NO DISPLAY")=1
GOTO X2
+8 IF $LENGTH(X,"-")=3
IF $PIECE(X,"-")]""
WRITE $CHAR(7)," ??"
SET APCHA=1
SET APCH("NO DISPLAY")=1
GOTO X2
+9 IF $EXTRACT(X)="-"
SET APCHSUB=1
Begin DoDot:1
+10 SET APCHSAVE("X")=X
+11 IF $LENGTH(X,"-")=3
SET X=$PIECE(APCHSAVE("X"),"-",2)
SET APCHTYP="LOW"
DO LOOK
IF 'APCHA
SET X=$PIECE(APCHSAVE("X"),"-",3)
SET APCHTYP="HI"
WRITE !
DO LOOK
QUIT
+12 IF $LENGTH(APCHSAVE("X"),"-")=2
SET X=$EXTRACT(X,2,99)
SET APCHTYP="LOW"
SET APCHONE=1
DO LOOK
End DoDot:1
IF 1
+13 IF '$TEST
SET APCHSAVE("X")=X
SET APCHTYP="LOW"
SET X=$PIECE(APCHSAVE("X"),"-")
DO LOOK
IF 'APCHA
SET APCHTYP="HI"
SET X=$PIECE(APCHSAVE("X"),"-",2)
WRITE !
DO LOOK
X2 QUIT
+1 ;
DISPLAY ;EP - SHOW CODES IN RANGE SELECTED
+1 IF $DATA(IOF)
WRITE @IOF
+2 ;W !!,"CPT codes in this range =>",!! W $P(APCH("LOW")," ") S APCHDFN=$O(^ICPT("BA",APCH("LOW"),"")) W ?9,$P(^ICPT(APCHDFN,0),U,2) ;cmi/anch/maw 8/28/2007 orig line
+3 ;cmi/anch/maw 8/28/2007 code set versioning
WRITE !!,"CPT codes in this range =>",!!
WRITE $PIECE(APCH("LOW")," ")
SET APCHDFN=$ORDER(^ICPT("BA",APCH("LOW"),""))
WRITE ?9,$PIECE($$CPT^ICPTCOD(APCHDFN),U,3)
+4 ;S APCH=APCH("LOW"),APCHCNT=IOSL-2 F S APCH=$O(^ICPT("BA",APCH)) Q:APCH]APCH("HI") S APCHDFN=$O(^(APCH,"")) W !,$P(APCH," "),?9,$P(^ICPT(APCHDFN,0),U,2) S APCHCNT=APCHCNT-1 I APCHCNT=0 S APCHCNT=IOSL-2 D I APCHR=U Q
+5 ; ;cmi/anch/maw 8/28/2007 orig line
+6 SET APCH=APCH("LOW")
SET APCHCNT=IOSL-2
+7 ;cmi/anch/maw 8/28/2007 code set versioning
FOR
SET APCH=$ORDER(^ICPT("BA",APCH))
IF APCH]APCH("HI")
QUIT
SET APCHDFN=$ORDER(^(APCH,""))
WRITE !,$PIECE(APCH," "),?9,$PIECE($$CPT^ICPTCOD(APCHDFN),U,3)
SET APCHCNT=APCHCNT-1
IF APCHCNT=0
SET APCHCNT=IOSL-2
Begin DoDot:1
A1 READ !,"<>",APCHR:DTIME
IF APCHR["?"
WRITE " Enter ""^"" to stop display, return to continue"
IF APCHR["?"
GOTO A1
End DoDot:1
IF APCHR=U
QUIT
+1 IF $SELECT('$DATA(APCHR):1,APCHR'=U:1,1:0)
READ !!,"Press return to continue",APCHR:DTIME
+2 WRITE !
+3 KILL APCHR
QUIT
+4 ;
RANGES ;DISPLAY TABLE OF ALL RANGES
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !!,"CPT Code Range(s) Selected So Far =>",!
+3 SET (APCH("NUM"),APCH)=0
FOR
SET APCH=$ORDER(APCHTBLE(APCH))
IF APCH=""
QUIT
SET APCH("NUM")=APCH("NUM")+1
WRITE !,APCH("NUM"),") ",APCH,$SELECT(APCH'=APCHTBLE(APCH):"- "_APCHTBLE(APCH),1:"")
+4 IF '$DATA(APCH("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 APCH("N"):300
IF "^"[APCH("N")
WRITE !
IF "^"[APCH("N")
QUIT
IF APCH("N")'?1N!(APCH("N")>APCH("NUM"))
WRITE " ??",$CHAR(7)
GOTO A
+1 FOR APCHI=1:1:APCH("N")
SET APCH=$ORDER(APCHTBLE(APCH))
IF APCHI=APCH("N")
SET APCH("LOW")=APCH
SET APCH("HI")=APCHTBLE(APCH)
DO DISPLAY
QUIT
+2 SET APCH("BANG")=""
DO RANGES
KILL APCH("BANG")
+3 QUIT
+4 ;
TAX ;PLACE CODES FROM SELECTED TAXONOMY IN APCHTBLE
+1 SET APCH("S")="I Y'=APCHX"
SET APCH("S")=$SELECT($DATA(APCHX):APCH("S")_",$O(^ATXAX(Y,21,0))",1:"I $O(^(21,0))")
SET DIC("A")="TAXONOMY FROM WHICH TO SELECT CODES: "
SET APCH("S")=APCH("S")_$SELECT('$DATA(APCHX):"",1:",$P(^ATXAX(APCHX,0),U,15)=$P(^ATXAX(Y,0),U,15)")
+2 IF $EXTRACT(X,2)="?"
SET X="?"
SET DIC="^ATXAX("
SET DIC(0)="EM"
SET DIC("S")=APCH("S")
DO ^DIC
SET DIC(0)="AEMQ"
SET DIC("S")=APCH("S")
SET DIC="^ATXAX("
DO ^DIC
KILL DIC
IF 1
+3 IF '$TEST
SET X=$EXTRACT(X,2,99)
SET DIC(0)="EMQ"
SET DIC("S")=APCH("S")
SET DIC="^ATXAX("
DO ^DIC
KILL DIC
+4 IF Y=-1
GOTO X3
+5 SET APCH("CODE")=0
FOR
SET APCH("CODE")=$ORDER(^ATXAX(+Y,21,"AA",APCH("CODE")))
IF APCH("CODE")=""
QUIT
SET APCHTBLE(APCH("CODE"))=$ORDER(^(APCH("CODE"),""))
X3 WRITE !
QUIT
+1 ;
CHECK ;ASKS USER IF SATISFIED WITH ENTERED RANGES
+1 WRITE !
SET DIR(0)="Y"
SET DIR("B")="Y"
SET DIR("A")="Is everything okay"
DO ^DIR
KILL DIR
+2 WRITE !
+3 QUIT
+4 ;
EOJ ;
+1 KILL APCHSUB,APCHTYP,APCHDFN,DIR,APCHSAVE,APCHA,APCHCNT,APCH,APCHR,APCHI,APCHONE,APCHFLG,APCHSTP
+2 QUIT
+3 ;
SETDIR ; ENTRY POINT - SETS HELP AND DIR FOR INIT SUBROUTINE OF APCHCODE
+1 SET DIR(0)="FO"
SET DIR("?",1)="Enter cpt code or narrative. You may enter a range of"
SET DIR("?",2)="codes by placing a ""-"" between two codes. Codes in a range will"
+2 SET DIR("?",3)="include the first and last codes indicated and all codes that fall"
SET DIR("?",4)="between. Only one code or one range of codes at a time. You may"
+3 SET DIR("?",5)="also enter ""[TAXONOMY NAME"" to select codes already within a taxonomy."
+4 SET DIR("?",6)="You can also ""de-select"" a code or range of codes by placing a ""-"" in"
SET DIR("?",7)="front of it. (e.g. '-250.00' or '-250.01-250.91') Enter ""??"" to see"
+5 SET DIR("?")="code ranges selected so far."
+6 SET DIR("??")="^D ASK2"
+7 QUIT
+8 ;
LOOK ; ENTRY POINT - LOOKUP USER RESPONSE; SET UTILITY NODES
+1 SET DIC="^ICPT("
SET DIC(0)="EMF"
DO ^DIC
KILL DIC,DR
+2 IF Y<0
SET APCHA=1
WRITE $CHAR(7)," ??"
SET APCH("NO DISPLAY")=1
GOTO X5
+3 IF APCHTYP="LOW"
SET APCH("LOW")=$PIECE(^ICPT(+Y,0),U)_" "
+4 IF APCHTYP="LOW"
IF APCHONE
SET APCH("HI")=APCH("LOW")
DO ^APCHTAXN
+5 IF APCHTYP="HI"
SET APCH("HI")=$PIECE(^ICPT(+Y,0),U)_" "
Begin DoDot:1
+6 IF $EXTRACT(APCH("HI"))?1N&($EXTRACT(APCH("LOW"))?1N)!($EXTRACT(APCH("LOW"))'?1N&($EXTRACT(APCH("HI"))'?1N))
+7 IF '$TEST
WRITE !,$CHAR(7),"Low and high codes of range must both start either with a letter or a number.",!
SET APCH("NO DISPLAY")=1
+8 IF 'APCH("NO DISPLAY")
IF APCH("LOW")]APCH("HI")
WRITE !,$CHAR(7),"Low code is higher than high code.",!
SET APCH("NO DISPLAY")=1
End DoDot:1
IF 'APCH("NO DISPLAY")
DO DISPLAY^APCHTAXM
DO ^APCHTAXN
X5 QUIT
+1 ;
ASK2 ;ASKS USER IF WANTS TO DISPLAY/PRINT RESULTS TO THIS POINT
+1 IF '$DATA(APCHTBLE)
WRITE !!,"A code range has yet to be selected. A display cannot be generated.",!
QUIT
+2 WRITE !!,"Do you want to display the codes from a range you have already selected"
SET %=1
DO YN^DICN
IF %=1
DO SHOW^APCHTAXM
+3 IF %=2!(%=-1)
QUIT
+4 IF %=0
WRITE !!,"A table of ranges you have selected is displayed above. You may ask for the",!,"codes in one of the ranges to be displayed.",!
GOTO ASK2
+5 QUIT
+6 ;
