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 ;
