BDMCODE.m

BDMCODE ; IHS/CMI/LAB - INTERFACE TO SELECT ICD CODES ;

 ;;2.0;DIABETES MANAGEMENT SYSTEM;**8**;JUN 14, 2007;Build 53

 ;

 ;cmi/anch/maw 9/10/2007 code set versioning in DISPLAY

 ;

 D INIT

BEGIN D ASK1

 I Y="^" S BDMSTP=1 G X

 I $D(BDMTBLE) D CHECK I Y'=1 G @$S(Y=0:"BEGIN",1:"X")

X D EOJ

 Q

 ;

INIT ;

 S BDM("NO DISPLAY")=0

 I $D(BDMX) D  I 1

 . I $D(BDMTBLE) S BDM("MODIFY")=1 D RANGES I 1

 . E  S BDM("ENTER")=1

 E  S BDM("NOT TAX")=""

 Q

 ;

ASK1 ;

 S BDMA=0

 K BDM("LOW"),BDM("HI")

 S DIR("A")=$S('$D(BDMTBLE):"ENTER DX",1:"ENTER ANOTHER DX") D SETDIR^BDMCOD0,^DIR K DIR

 I "^"[Y G X1

 D PROCESS

 I $D(BDMTBLE),'BDM("NO DISPLAY") D RANGES

 S BDM("NO DISPLAY")=0

 G ASK1

X1 Q

 ;

PROCESS ;EVALUATE USER RESPONSE

 S (BDMSUB,BDMONE)=0 ;BDMSUB=0 => NO DELETE OF CODE(S),BDMONE=0 => RANGE OF CODES ENTERED

 I $E(X,1,2)="-[" W $C(7),"  ?? Not allowed" S BDM("NO DISPLAY")=1 G X2

 I $E(X)="[" D TAX G X2

 I X'["-" S BDMTYP="LOW",BDMONE=1 D LOOK^BDMCOD0 G X2

 I $E(X)="-",'$D(BDMTBLE) W $C(7),"  ??  No previous codes entered!" G X2

 I $L(X,"-")>3 W $C(7),"  ??"  S BDMA=1 S BDM("NO DISPLAY")=1 G X2

 I $L(X,"-")=3,$E(X,$L(X))="-" W $C(7),"  ??" S BDMA=1 S BDM("NO DISPLAY")=1 G X2

 I $L(X,"-")=3,$P(X,"-")]"" W $C(7),"  ??" S BDMA=1 S BDM("NO DISPLAY")=1 G X2

 I $E(X)="-" S BDMSUB=1 D  I 1

 . S BDMSAVE("X")=X

 . I $L(X,"-")=3 S X=$P(BDMSAVE("X"),"-",2),BDMTYP="LOW" D LOOK^BDMCOD0 I 'BDMA S X=$P(BDMSAVE("X"),"-",3),BDMTYP="HI" W ! D LOOK^BDMCOD0 Q

 . I $L(BDMSAVE("X"),"-")=2 S X=$E(X,2,99),BDMTYP="LOW",BDMONE=1 D LOOK^BDMCOD0

 E  S BDMSAVE("X")=X S BDMTYP="LOW",X=$P(BDMSAVE("X"),"-") D LOOK^BDMCOD0 I 'BDMA S BDMTYP="HI",X=$P(BDMSAVE("X"),"-",2) W ! D LOOK^BDMCOD0

X2 Q

 ;

DISPLAY ;EP - SHOW CODES IN RANGE SELECTED

 W:$D(IOF) @IOF

 ;W !!,"ICD codes in this range =>",!! W $P(BDM("LOW")," ") S BDMDFN=$O(^ICD9("BA",BDM("LOW"),"")) W ?9,$P(^ICD9(BDMDFN,0),U,3)  ;cmi/anch/maw 9/10/2007 orig line

 W !!,"ICD codes in this range =>",!! W $P(BDM("LOW")," ") S BDMDFN=$O(^ICD9("BA",BDM("LOW"),"")) W ?9,$P($$ICDDX^BDMUTL(BDMDFN),U,4)  ;cmi/anch/maw 9/10/2007 csv

 ;S BDM=BDM("LOW"),BDMCNT=IOSL-2 F  S BDM=$O(^ICD9("BA",BDM)) Q:BDM]BDM("HI")  S BDMDFN=$O(^(BDM,"")) W !,$P(BDM," "),?9,$P(^ICD9(BDMDFN,0),U,3) S BDMCNT=BDMCNT-1 I BDMCNT=0 S BDMCNT=IOSL-2 D  I BDMR=U Q  ;cmi/anch/maw orig line

 S BDM=BDM("LOW"),BDMCNT=IOSL-2 F  S BDM=$O(^ICD9("BA",BDM)) Q:BDM]BDM("HI")  S BDMDFN=$O(^(BDM,"")) W !,$P(BDM," "),?9,$P($$ICDDX^BDMUTL(BDMDFN),U,4) S BDMCNT=BDMCNT-1 I BDMCNT=0 S BDMCNT=IOSL-2 D  I BDMR=U Q  ;cmi/maw csv

A1 . R !,"<>",BDMR:DTIME W:BDMR["?" " Enter ""^"" to stop display, return to continue" G:BDMR["?" A1

 I $S('$D(BDMR):1,BDMR'=U:1,1:0) R !!,"Press return to continue",BDMR:DTIME

 W !

 K BDMR Q

 ;

RANGES ;DISPLAY TABLE OF ALL RANGES

 W:$D(IOF) @IOF

 W !!,"ICD Code Range(s) Selected So Far =>",!

 S (BDM("NUM"),BDM)=0 F  S BDM=$O(BDMTBLE(BDM)) Q:BDM=""  S BDM("NUM")=BDM("NUM")+1 W !,BDM("NUM"),")  ",BDM,$S(BDM'=BDMTBLE(BDM):"- "_BDMTBLE(BDM),1:"")

 I '$D(BDM("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 BDM("N"):300 W:"^"[BDM("N") ! Q:"^"[BDM("N")  I BDM("N")'?1N!(BDM("N")>BDM("NUM")) W "  ??",$C(7) G A

 F BDMI=1:1:BDM("N") S BDM=$O(BDMTBLE(BDM)) I BDMI=BDM("N") S BDM("LOW")=BDM,BDM("HI")=BDMTBLE(BDM) D DISPLAY Q

 S BDM("BANG")="" D RANGES K BDM("BANG")

 Q

 ;

TAX ;PLACE CODES FROM SELECTED TAXONOMY IN BDMTBLE

 S BDM("S")="I Y'=BDMX",BDM("S")=$S($D(BDMX):BDM("S")_",$O(^ATXAX(Y,21,0))",1:"I $O(^(21,0))"),DIC("A")="TAXONOMY FROM WHICH TO SELECT CODES: ",BDM("S")=BDM("S")_$S('$D(BDMX):"",1:",$P(^ATXAX(BDMX,0),U,15)=$P(^ATXAX(Y,0),U,15)")

 I $E(X,2)="?" S X="?",DIC="^ATXAX(",DIC(0)="EM",DIC("S")=BDM("S") D ^DIC S DIC(0)="AEMQ",DIC("S")=BDM("S"),DIC="^ATXAX(" D ^DIC K DIC I 1

 E  S X=$E(X,2,99),DIC(0)="EMQ",DIC("S")=BDM("S"),DIC="^ATXAX(" D ^DIC K DIC

 I Y=-1 G X3

 S BDM("CODE")=0 F  S BDM("CODE")=$O(^ATXAX(+Y,21,"AA",BDM("CODE"))) Q:BDM("CODE")=""  S BDMTBLE(BDM("CODE"))=$O(^(BDM("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 BDMSUB,BDMTYP,BDMDFN,DIR,BDMSAVE,BDMA,BDMCNT,BDM,BDMR,BDMI,BDMONE,BDMFLG,BDMSTP

 Q

 ;

BDMCODE   ; IHS/CMI/LAB - INTERFACE TO SELECT ICD CODES ;

 +1       ;;2.0;DIABETES MANAGEMENT SYSTEM;**8**;JUN 14, 2007;Build 53

 +2       ;

 +3       ;cmi/anch/maw 9/10/2007 code set versioning in DISPLAY

 +4       ;

 +5        DO INIT

BEGIN      DO ASK1

 +1        IF Y="^"

               SET BDMSTP=1

               GOTO X

 +2        IF $DATA(BDMTBLE)

               DO CHECK

               IF Y'=1

                   GOTO @$SELECT(Y=0:"BEGIN",1:"X")

X          DO EOJ

 +1        QUIT 

 +2       ;

INIT      ;

 +1        SET BDM("NO DISPLAY")=0

 +2        IF $DATA(BDMX)

               Begin DoDot:1

 +3                IF $DATA(BDMTBLE)

                       SET BDM("MODIFY")=1

                       DO RANGES

                       IF 1

 +4               IF '$TEST

                       SET BDM("ENTER")=1

               End DoDot:1

               IF 1

 +5       IF '$TEST

               SET BDM("NOT TAX")=""

 +6        QUIT 

 +7       ;

ASK1      ;

 +1        SET BDMA=0

 +2        KILL BDM("LOW"),BDM("HI")

 +3        SET DIR("A")=$SELECT('$DATA(BDMTBLE):"ENTER DX",1:"ENTER ANOTHER DX")

           DO SETDIR^BDMCOD0

           DO ^DIR

           KILL DIR

 +4        IF "^"[Y

               GOTO X1

 +5        DO PROCESS

 +6        IF $DATA(BDMTBLE)

               IF 'BDM("NO DISPLAY")

                   DO RANGES

 +7        SET BDM("NO DISPLAY")=0

 +8        GOTO ASK1

X1         QUIT 

 +1       ;

PROCESS   ;EVALUATE USER RESPONSE

 +1       ;BDMSUB=0 => NO DELETE OF CODE(S),BDMONE=0 => RANGE OF CODES ENTERED

           SET (BDMSUB,BDMONE)=0

 +2        IF $EXTRACT(X,1,2)="-["

               WRITE $CHAR(7),"  ?? Not allowed"

               SET BDM("NO DISPLAY")=1

               GOTO X2

 +3        IF $EXTRACT(X)="["

               DO TAX

               GOTO X2

 +4        IF X'["-"

               SET BDMTYP="LOW"

               SET BDMONE=1

               DO LOOK^BDMCOD0

               GOTO X2

 +5        IF $EXTRACT(X)="-"

               IF '$DATA(BDMTBLE)

                   WRITE $CHAR(7),"  ??  No previous codes entered!"

                   GOTO X2

 +6        IF $LENGTH(X,"-")>3

               WRITE $CHAR(7),"  ??"

               SET BDMA=1

               SET BDM("NO DISPLAY")=1

               GOTO X2

 +7        IF $LENGTH(X,"-")=3

               IF $EXTRACT(X,$LENGTH(X))="-"

                   WRITE $CHAR(7),"  ??"

                   SET BDMA=1

                   SET BDM("NO DISPLAY")=1

                   GOTO X2

 +8        IF $LENGTH(X,"-")=3

               IF $PIECE(X,"-")]""

                   WRITE $CHAR(7),"  ??"

                   SET BDMA=1

                   SET BDM("NO DISPLAY")=1

                   GOTO X2

 +9        IF $EXTRACT(X)="-"

               SET BDMSUB=1

               Begin DoDot:1

 +10               SET BDMSAVE("X")=X

 +11               IF $LENGTH(X,"-")=3

                       SET X=$PIECE(BDMSAVE("X"),"-",2)

                       SET BDMTYP="LOW"

                       DO LOOK^BDMCOD0

                       IF 'BDMA

                           SET X=$PIECE(BDMSAVE("X"),"-",3)

                           SET BDMTYP="HI"

                           WRITE !

                           DO LOOK^BDMCOD0

                           QUIT 

 +12               IF $LENGTH(BDMSAVE("X"),"-")=2

                       SET X=$EXTRACT(X,2,99)

                       SET BDMTYP="LOW"

                       SET BDMONE=1

                       DO LOOK^BDMCOD0

               End DoDot:1

               IF 1

 +13      IF '$TEST

               SET BDMSAVE("X")=X

               SET BDMTYP="LOW"

               SET X=$PIECE(BDMSAVE("X"),"-")

               DO LOOK^BDMCOD0

               IF 'BDMA

                   SET BDMTYP="HI"

                   SET X=$PIECE(BDMSAVE("X"),"-",2)

                   WRITE !

                   DO LOOK^BDMCOD0

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(BDM("LOW")," ") S BDMDFN=$O(^ICD9("BA",BDM("LOW"),"")) W ?9,$P(^ICD9(BDMDFN,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(BDM("LOW")," ")

           SET BDMDFN=$ORDER(^ICD9("BA",BDM("LOW"),""))

           WRITE ?9,$PIECE($$ICDDX^BDMUTL(BDMDFN),U,4)

 +4       ;S BDM=BDM("LOW"),BDMCNT=IOSL-2 F  S BDM=$O(^ICD9("BA",BDM)) Q:BDM]BDM("HI")  S BDMDFN=$O(^(BDM,"")) W !,$P(BDM," "),?9,$P(^ICD9(BDMDFN,0),U,3) S BDMCNT=BDMCNT-1 I BDMCNT=0 S BDMCNT=IOSL-2 D  I BDMR=U Q  ;cmi/anch/maw orig line

 +5       ;cmi/maw csv

           SET BDM=BDM("LOW")

           SET BDMCNT=IOSL-2

           FOR 

               SET BDM=$ORDER(^ICD9("BA",BDM))

               IF BDM]BDM("HI")

                   QUIT 

               SET BDMDFN=$ORDER(^(BDM,""))

               WRITE !,$PIECE(BDM," "),?9,$PIECE($$ICDDX^BDMUTL(BDMDFN),U,4)

               SET BDMCNT=BDMCNT-1

               IF BDMCNT=0

                   SET BDMCNT=IOSL-2

                   Begin DoDot:1

A1                     READ !,"<>",BDMR:DTIME

                       IF BDMR["?"

                           WRITE " Enter ""^"" to stop display, return to continue"

                       IF BDMR["?"

                           GOTO A1

                   End DoDot:1

                   IF BDMR=U

                       QUIT 

 +1        IF $SELECT('$DATA(BDMR):1,BDMR'=U:1,1:0)

               READ !!,"Press return to continue",BDMR:DTIME

 +2        WRITE !

 +3        KILL BDMR

           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 (BDM("NUM"),BDM)=0

           FOR 

               SET BDM=$ORDER(BDMTBLE(BDM))

               IF BDM=""

                   QUIT 

               SET BDM("NUM")=BDM("NUM")+1

               WRITE !,BDM("NUM"),")  ",BDM,$SELECT(BDM'=BDMTBLE(BDM):"- "_BDMTBLE(BDM),1:"")

 +4        IF '$DATA(BDM("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 BDM("N"):300

           IF "^"[BDM("N")

               WRITE !

           IF "^"[BDM("N")

               QUIT 

           IF BDM("N")'?1N!(BDM("N")>BDM("NUM"))

               WRITE "  ??",$CHAR(7)

               GOTO A

 +1        FOR BDMI=1:1:BDM("N")

               SET BDM=$ORDER(BDMTBLE(BDM))

               IF BDMI=BDM("N")

                   SET BDM("LOW")=BDM

                   SET BDM("HI")=BDMTBLE(BDM)

                   DO DISPLAY

                   QUIT 

 +2        SET BDM("BANG")=""

           DO RANGES

           KILL BDM("BANG")

 +3        QUIT 

 +4       ;

TAX       ;PLACE CODES FROM SELECTED TAXONOMY IN BDMTBLE

 +1        SET BDM("S")="I Y'=BDMX"

           SET BDM("S")=$SELECT($DATA(BDMX):BDM("S")_",$O(^ATXAX(Y,21,0))",1:"I $O(^(21,0))")

           SET DIC("A")="TAXONOMY FROM WHICH TO SELECT CODES: "

           SET BDM("S")=BDM("S")_$SELECT('$DATA(BDMX):"",1:",$P(^ATXAX(BDMX,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")=BDM("S")

               DO ^DIC

               SET DIC(0)="AEMQ"

               SET DIC("S")=BDM("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")=BDM("S")

               SET DIC="^ATXAX("

               DO ^DIC

               KILL DIC

 +4        IF Y=-1

               GOTO X3

 +5        SET BDM("CODE")=0

           FOR 

               SET BDM("CODE")=$ORDER(^ATXAX(+Y,21,"AA",BDM("CODE")))

               IF BDM("CODE")=""

                   QUIT 

               SET BDMTBLE(BDM("CODE"))=$ORDER(^(BDM("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 BDMSUB,BDMTYP,BDMDFN,DIR,BDMSAVE,BDMA,BDMCNT,BDM,BDMR,BDMI,BDMONE,BDMFLG,BDMSTP

 +2        QUIT 

 +3       ;