APCLCODE ; IHS/CMI/LAB - 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
;
D INIT
BEGIN D ASK1
I Y="^" S APCLSTP=1 G X
I $D(APCLTBLE) D CHECK I Y'=1 G @$S(Y=0:"BEGIN",1:"X")
X D EOJ
Q
;
INIT ;
S APCL("NO DISPLAY")=0
I $D(APCLX) D I 1
. I $D(APCLTBLE) S APCL("MODIFY")=1 D RANGES I 1
. E S APCL("ENTER")=1
E S APCL("NOT TAX")=""
Q
;
ASK1 ;
S APCLA=0
K APCL("LOW"),APCL("HI")
S DIR("A")=$S('$D(APCLTBLE):"ENTER DX",1:"ENTER ANOTHER DX") D SETDIR^APCLCOD0,^DIR K DIR
I "^"[Y G X1
D PROCESS
I $D(APCLTBLE),'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)="[" D TAX G X2
I X'["-" S APCLTYP="LOW",APCLONE=1 D LOOK^APCLCOD0 G X2
I $E(X)="-",'$D(APCLTBLE) 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^APCLCOD0 I 'APCLA S X=$P(APCLSAVE("X"),"-",3),APCLTYP="HI" W ! D LOOK^APCLCOD0 Q
. I $L(APCLSAVE("X"),"-")=2 S X=$E(X,2,99),APCLTYP="LOW",APCLONE=1 D LOOK^APCLCOD0
E S APCLSAVE("X")=X S APCLTYP="LOW",X=$P(APCLSAVE("X"),"-") D LOOK^APCLCOD0 I 'APCLA S APCLTYP="HI",X=$P(APCLSAVE("X"),"-",2) W ! D LOOK^APCLCOD0
X2 Q
;
DISPLAY ;EP - SHOW CODES IN RANGE SELECTED
W:$D(IOF) @IOF
;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 =>",!! W $P(APCL("LOW")," ") S APCLDFN=$O(^ICD9("BA",APCL("LOW"),"")) W ?9,$P($$ICDDX^ICDEX(APCLDFN),U,4) ;cmi/anch/maw 9/10/2007 csv
;S APCL=APCL("LOW"),APCLCNT=IOSL-2 F S APCL=$O(^ICD9("BA",APCL)) Q:APCL]APCL("HI") S APCLDFN=$O(^(APCL,"")) W !,$P(APCL," "),?9,$P(^ICD9(APCLDFN,0),U,3) S APCLCNT=APCLCNT-1 I APCLCNT=0 S APCLCNT=IOSL-2 D I APCLR=U Q ;cmi/anch/maw orig line
S APCL=APCL("LOW"),APCLCNT=IOSL-2 F S APCL=$O(^ICD9("BA",APCL)) Q:APCL]APCL("HI") S APCLDFN=$O(^(APCL,"")) W !,$P(APCL," "),?9,$P($$ICDDX^ICDEX(APCLDFN),U,4) S APCLCNT=APCLCNT-1 I APCLCNT=0 S APCLCNT=IOSL-2 D I APCLR=U Q ;cmi/maw csv
A1 . R !,"<>",APCLR:DTIME W:APCLR["?" " Enter ""^"" to stop display, return to continue" G:APCLR["?" A1
I $S('$D(APCLR):1,APCLR'=U:1,1:0) R !!,"Press return to continue",APCLR:DTIME
W !
K APCLR 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(APCLTBLE(APCL)) Q:APCL="" S APCL("NUM")=APCL("NUM")+1 W !,APCL("NUM"),") ",APCL,$S(APCL'=APCLTBLE(APCL):"- "_APCLTBLE(APCL),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(APCLTBLE(APCL)) I APCLI=APCL("N") S APCL("LOW")=APCL,APCL("HI")=APCLTBLE(APCL) D DISPLAY Q
S APCL("BANG")="" D RANGES K APCL("BANG")
Q
;
TAX ;PLACE CODES FROM SELECTED TAXONOMY IN APCLTBLE
S APCL("S")="I Y'=APCLX",APCL("S")=$S($D(APCLX):APCL("S")_",$O(^ATXAX(Y,21,0))",1:"I $O(^(21,0))"),DIC("A")="TAXONOMY FROM WHICH TO SELECT CODES: ",APCL("S")=APCL("S")_$S('$D(APCLX):"",1:",$P(^ATXAX(APCLX,0),U,15)=$P(^ATXAX(Y,0),U,15)")
I $E(X,2)="?" S X="?",DIC="^ATXAX(",DIC(0)="EM",DIC("S")=APCL("S") D ^DIC S DIC(0)="AEMQ",DIC("S")=APCL("S"),DIC="^ATXAX(" D ^DIC K DIC I 1
E S X=$E(X,2,99),DIC(0)="EMQ",DIC("S")=APCL("S"),DIC="^ATXAX(" D ^DIC K DIC
I Y=-1 G X3
S APCL("CODE")=0 F S APCL("CODE")=$O(^ATXAX(+Y,21,"AA",APCL("CODE"))) Q:APCL("CODE")="" S APCLTBLE(APCL("CODE"))=$O(^(APCL("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 APCLSUB,APCLTYP,APCLDFN,DIR,APCLSAVE,APCLA,APCLCNT,APCL,APCLR,APCLI,APCLONE,APCLFLG,APCLSTP
Q
;
APCLCODE ; IHS/CMI/LAB - 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
+4 ;
+5 DO INIT
BEGIN DO ASK1
+1 IF Y="^"
SET APCLSTP=1
GOTO X
+2 IF $DATA(APCLTBLE)
DO CHECK
IF Y'=1
GOTO @$SELECT(Y=0:"BEGIN",1:"X")
X DO EOJ
+1 QUIT
+2 ;
INIT ;
+1 SET APCL("NO DISPLAY")=0
+2 IF $DATA(APCLX)
Begin DoDot:1
+3 IF $DATA(APCLTBLE)
SET APCL("MODIFY")=1
DO RANGES
IF 1
+4 IF '$TEST
SET APCL("ENTER")=1
End DoDot:1
IF 1
+5 IF '$TEST
SET APCL("NOT TAX")=""
+6 QUIT
+7 ;
ASK1 ;
+1 SET APCLA=0
+2 KILL APCL("LOW"),APCL("HI")
+3 SET DIR("A")=$SELECT('$DATA(APCLTBLE):"ENTER DX",1:"ENTER ANOTHER DX")
DO SETDIR^APCLCOD0
DO ^DIR
KILL DIR
+4 IF "^"[Y
GOTO X1
+5 DO PROCESS
+6 IF $DATA(APCLTBLE)
IF 'APCL("NO DISPLAY")
DO RANGES
+7 SET APCL("NO DISPLAY")=0
+8 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)="["
DO TAX
GOTO X2
+4 IF X'["-"
SET APCLTYP="LOW"
SET APCLONE=1
DO LOOK^APCLCOD0
GOTO X2
+5 IF $EXTRACT(X)="-"
IF '$DATA(APCLTBLE)
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^APCLCOD0
IF 'APCLA
SET X=$PIECE(APCLSAVE("X"),"-",3)
SET APCLTYP="HI"
WRITE !
DO LOOK^APCLCOD0
QUIT
+12 IF $LENGTH(APCLSAVE("X"),"-")=2
SET X=$EXTRACT(X,2,99)
SET APCLTYP="LOW"
SET APCLONE=1
DO LOOK^APCLCOD0
End DoDot:1
IF 1
+13 IF '$TEST
SET APCLSAVE("X")=X
SET APCLTYP="LOW"
SET X=$PIECE(APCLSAVE("X"),"-")
DO LOOK^APCLCOD0
IF 'APCLA
SET APCLTYP="HI"
SET X=$PIECE(APCLSAVE("X"),"-",2)
WRITE !
DO LOOK^APCLCOD0
X2 QUIT
+1 ;
DISPLAY ;EP - SHOW CODES IN RANGE SELECTED
+1 IF $DATA(IOF)
WRITE @IOF
+2 ;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
+3 ;cmi/anch/maw 9/10/2007 csv
WRITE !!,"ICD codes in this range =>",!!
WRITE $PIECE(APCL("LOW")," ")
SET APCLDFN=$ORDER(^ICD9("BA",APCL("LOW"),""))
WRITE ?9,$PIECE($$ICDDX^ICDEX(APCLDFN),U,4)
+4 ;S APCL=APCL("LOW"),APCLCNT=IOSL-2 F S APCL=$O(^ICD9("BA",APCL)) Q:APCL]APCL("HI") S APCLDFN=$O(^(APCL,"")) W !,$P(APCL," "),?9,$P(^ICD9(APCLDFN,0),U,3) S APCLCNT=APCLCNT-1 I APCLCNT=0 S APCLCNT=IOSL-2 D I APCLR=U Q ;cmi/anch/maw orig line
+5 ;cmi/maw csv
SET APCL=APCL("LOW")
SET APCLCNT=IOSL-2
FOR
SET APCL=$ORDER(^ICD9("BA",APCL))
IF APCL]APCL("HI")
QUIT
SET APCLDFN=$ORDER(^(APCL,""))
WRITE !,$PIECE(APCL," "),?9,$PIECE($$ICDDX^ICDEX(APCLDFN),U,4)
SET APCLCNT=APCLCNT-1
IF APCLCNT=0
SET APCLCNT=IOSL-2
Begin DoDot:1
A1 READ !,"<>",APCLR:DTIME
IF APCLR["?"
WRITE " Enter ""^"" to stop display, return to continue"
IF APCLR["?"
GOTO A1
End DoDot:1
IF APCLR=U
QUIT
+1 IF $SELECT('$DATA(APCLR):1,APCLR'=U:1,1:0)
READ !!,"Press return to continue",APCLR:DTIME
+2 WRITE !
+3 KILL APCLR
QUIT
+4 ;
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(APCLTBLE(APCL))
IF APCL=""
QUIT
SET APCL("NUM")=APCL("NUM")+1
WRITE !,APCL("NUM"),") ",APCL,$SELECT(APCL'=APCLTBLE(APCL):"- "_APCLTBLE(APCL),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(APCLTBLE(APCL))
IF APCLI=APCL("N")
SET APCL("LOW")=APCL
SET APCL("HI")=APCLTBLE(APCL)
DO DISPLAY
QUIT
+2 SET APCL("BANG")=""
DO RANGES
KILL APCL("BANG")
+3 QUIT
+4 ;
TAX ;PLACE CODES FROM SELECTED TAXONOMY IN APCLTBLE
+1 SET APCL("S")="I Y'=APCLX"
SET APCL("S")=$SELECT($DATA(APCLX):APCL("S")_",$O(^ATXAX(Y,21,0))",1:"I $O(^(21,0))")
SET DIC("A")="TAXONOMY FROM WHICH TO SELECT CODES: "
SET APCL("S")=APCL("S")_$SELECT('$DATA(APCLX):"",1:",$P(^ATXAX(APCLX,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")=APCL("S")
DO ^DIC
SET DIC(0)="AEMQ"
SET DIC("S")=APCL("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")=APCL("S")
SET DIC="^ATXAX("
DO ^DIC
KILL DIC
+4 IF Y=-1
GOTO X3
+5 SET APCL("CODE")=0
FOR
SET APCL("CODE")=$ORDER(^ATXAX(+Y,21,"AA",APCL("CODE")))
IF APCL("CODE")=""
QUIT
SET APCLTBLE(APCL("CODE"))=$ORDER(^(APCL("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 APCLSUB,APCLTYP,APCLDFN,DIR,APCLSAVE,APCLA,APCLCNT,APCL,APCLR,APCLI,APCLONE,APCLFLG,APCLSTP
+2 QUIT
+3 ;
