APCLCODE.m

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       ;