- BDMSDX ; IHS/CMI/LAB - SWITCH CMS DIAGNOSIS LIST ENTRY ;
- ;;2.0;DIABETES MANAGEMENT SYSTEM;**3,4**;JUN 14, 2007
- ;
- ;This routine provides a utility to standardize entires in the CMS
- ;DIAGNOSIS LIST ENTRY file for diabetes related diagnoses.
- ;
- EN ;EP
- F D EN1 Q:$D(BDMQUIT)!$D(BDMOUT)
- EXIT K BDMQUIT,BDMOUT,BDMDX,BDMX,BDMY,BDMNEW,BDMOLD,BDMJ
- Q
- EN1 D EXIT
- D NEW
- Q:$D(BDMQUIT)
- D OLD
- Q:$D(BDMQUIT)!'$D(BDMDX)
- D SURE
- I $D(BDMQUIT) K BDMQUIT Q
- D POINT
- Q
- NEW ;LIST NEW DMS DIAGNOSES AND SELECT DX TO UPDATE
- W @IOF
- W !,"Select the DMS DIAGNOSIS"
- S DIR(0)="SO^1:TYPE 1;2:TYPE 2;3:GESTATIONAL DM;4:IMPAIRED GLUCOSE TOLERANCE"
- S DIR("A")="Which DX"
- D DIR^BDMFDIC
- I Y<1 S BDMQUIT="" Q
- S BDMX=$O(^ACM(44.1,"B",Y(0),0))
- I 'BDMX S BDMQUIT="" Q
- S BDMX=BDMX_U_$P(^ACM(44.1,BDMX,0),U)
- Q
- OLD ;SELECT OLD CMS DIAGNOSES TO REPORT TO NEW DMS DIAGNOSIS
- S J=0
- F D O1 Q:$D(BDMQUIT)!$D(BDMOUT)
- K BDMQUIT
- Q
- O1 D LOLD
- S DIC="^ACM(44.1,"
- S DIC(0)="AEMQZ"
- S DIC("A")="CMS DIAGNOSIS LIST ENTRY: "
- W !
- D DIC^BDMFDIC
- I Y<1 S BDMQUIT="" Q
- I +Y=+BDMX W !!,"Same as current Official DMS Diagnosis" H 3 Q
- S J=J+1
- S BDMDX(J)=+Y_U_Y(0)
- Q
- LOLD ;LIST OLD DX'S
- W @IOF
- W !,"Current CMS DIAGNOSIS LIST ENTRIES that will be changed to:"
- W !?5,$P(BDMX,U,2)
- W !!?5,"NO.",?10,"NAME"
- W !?5,"---",?10,"------------------------------"
- N X
- S X=0
- F S X=$O(BDMDX(X)) Q:'X D
- .W !?5,X,?10,$P(BDMDX(X),U,2)
- Q
- SURE ;LIST CHANGES TO BE MADE AND AFIRM
- S DIR(0)="YO"
- S DIR("A")="Are you certain you want to make these changes"
- S DIR("B")="NO"
- W !
- D DIR^BDMFDIC
- I Y'=1 S BDMQUIT="" Q
- Q
- POINT ;RE-POINT OLD CMS ENTRIES TO NEW DMS DX
- N BDM,BDMJ
- S BDMJ=0
- F S BDMJ=$O(BDMDX(BDMJ)) Q:'BDMJ D P1
- Q
- P1 N BDMNEW,BDMOLD
- ;S BDMNEW=+BDMX ;maw orig
- S BDMNEW=$P(BDMX,U,2) ;maw mod because of 4 slash stuff below not allowed 9/7/06
- S BDMOLD=+BDMDX(BDMJ)
- S BDMDA=0
- F S BDMDA=$O(^ACM(44,"B",BDMOLD,BDMDA)) Q:'BDMDA D
- .S DA=BDMDA
- .S DIE="^ACM(44,"
- .S DR=".01///"_BDMNEW
- .W "."
- .D DIE^BDMFDIC
- S DA=+BDMDX(BDMJ)
- S DIE="^ACM(44.1,"
- S DR=".01///"_"ZZ "_$P(BDMDX(BDMJ),U,2)
- W "."
- D DIE^BDMFDIC
- Q
- BDMSDX ; IHS/CMI/LAB - SWITCH CMS DIAGNOSIS LIST ENTRY ;
- +1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**3,4**;JUN 14, 2007
- +2 ;
- +3 ;This routine provides a utility to standardize entires in the CMS
- +4 ;DIAGNOSIS LIST ENTRY file for diabetes related diagnoses.
- +5 ;
- EN ;EP
- +1 FOR
- DO EN1
- IF $DATA(BDMQUIT)!$DATA(BDMOUT)
- QUIT
- EXIT KILL BDMQUIT,BDMOUT,BDMDX,BDMX,BDMY,BDMNEW,BDMOLD,BDMJ
- +1 QUIT
- EN1 DO EXIT
- +1 DO NEW
- +2 IF $DATA(BDMQUIT)
- QUIT
- +3 DO OLD
- +4 IF $DATA(BDMQUIT)!'$DATA(BDMDX)
- QUIT
- +5 DO SURE
- +6 IF $DATA(BDMQUIT)
- KILL BDMQUIT
- QUIT
- +7 DO POINT
- +8 QUIT
- NEW ;LIST NEW DMS DIAGNOSES AND SELECT DX TO UPDATE
- +1 WRITE @IOF
- +2 WRITE !,"Select the DMS DIAGNOSIS"
- +3 SET DIR(0)="SO^1:TYPE 1;2:TYPE 2;3:GESTATIONAL DM;4:IMPAIRED GLUCOSE TOLERANCE"
- +4 SET DIR("A")="Which DX"
- +5 DO DIR^BDMFDIC
- +6 IF Y<1
- SET BDMQUIT=""
- QUIT
- +7 SET BDMX=$ORDER(^ACM(44.1,"B",Y(0),0))
- +8 IF 'BDMX
- SET BDMQUIT=""
- QUIT
- +9 SET BDMX=BDMX_U_$PIECE(^ACM(44.1,BDMX,0),U)
- +10 QUIT
- OLD ;SELECT OLD CMS DIAGNOSES TO REPORT TO NEW DMS DIAGNOSIS
- +1 SET J=0
- +2 FOR
- DO O1
- IF $DATA(BDMQUIT)!$DATA(BDMOUT)
- QUIT
- +3 KILL BDMQUIT
- +4 QUIT
- O1 DO LOLD
- +1 SET DIC="^ACM(44.1,"
- +2 SET DIC(0)="AEMQZ"
- +3 SET DIC("A")="CMS DIAGNOSIS LIST ENTRY: "
- +4 WRITE !
- +5 DO DIC^BDMFDIC
- +6 IF Y<1
- SET BDMQUIT=""
- QUIT
- +7 IF +Y=+BDMX
- WRITE !!,"Same as current Official DMS Diagnosis"
- HANG 3
- QUIT
- +8 SET J=J+1
- +9 SET BDMDX(J)=+Y_U_Y(0)
- +10 QUIT
- LOLD ;LIST OLD DX'S
- +1 WRITE @IOF
- +2 WRITE !,"Current CMS DIAGNOSIS LIST ENTRIES that will be changed to:"
- +3 WRITE !?5,$PIECE(BDMX,U,2)
- +4 WRITE !!?5,"NO.",?10,"NAME"
- +5 WRITE !?5,"---",?10,"------------------------------"
- +6 NEW X
- +7 SET X=0
- +8 FOR
- SET X=$ORDER(BDMDX(X))
- IF 'X
- QUIT
- Begin DoDot:1
- +9 WRITE !?5,X,?10,$PIECE(BDMDX(X),U,2)
- End DoDot:1
- +10 QUIT
- SURE ;LIST CHANGES TO BE MADE AND AFIRM
- +1 SET DIR(0)="YO"
- +2 SET DIR("A")="Are you certain you want to make these changes"
- +3 SET DIR("B")="NO"
- +4 WRITE !
- +5 DO DIR^BDMFDIC
- +6 IF Y'=1
- SET BDMQUIT=""
- QUIT
- +7 QUIT
- POINT ;RE-POINT OLD CMS ENTRIES TO NEW DMS DX
- +1 NEW BDM,BDMJ
- +2 SET BDMJ=0
- +3 FOR
- SET BDMJ=$ORDER(BDMDX(BDMJ))
- IF 'BDMJ
- QUIT
- DO P1
- +4 QUIT
- P1 NEW BDMNEW,BDMOLD
- +1 ;S BDMNEW=+BDMX ;maw orig
- +2 ;maw mod because of 4 slash stuff below not allowed 9/7/06
- SET BDMNEW=$PIECE(BDMX,U,2)
- +3 SET BDMOLD=+BDMDX(BDMJ)
- +4 SET BDMDA=0
- +5 FOR
- SET BDMDA=$ORDER(^ACM(44,"B",BDMOLD,BDMDA))
- IF 'BDMDA
- QUIT
- Begin DoDot:1
- +6 SET DA=BDMDA
- +7 SET DIE="^ACM(44,"
- +8 SET DR=".01///"_BDMNEW
- +9 WRITE "."
- +10 DO DIE^BDMFDIC
- End DoDot:1
- +11 SET DA=+BDMDX(BDMJ)
- +12 SET DIE="^ACM(44.1,"
- +13 SET DR=".01///"_"ZZ "_$PIECE(BDMDX(BDMJ),U,2)
- +14 WRITE "."
- +15 DO DIE^BDMFDIC
- +16 QUIT
