BMCDXSTF.m

BMCDXSTF ; IHS/PHXAO/TMJ - Stuff Dx & CPT if Site Parameters Request stuffing ;   

 ;;4.0;REFERRED CARE INFO SYSTEM;**8,9**;JAN 09, 2006;Build 101

 ;IHS/ITSC/FCJ Killed DIADD var, was not allowing

 ;       lookup on the Prov. Nar file

 ;BMC*4.0*8 CSV added a space to the .9999 code now checking for ".9999 " for ICD9

 ;BMC*4.0*9 modified to .9999 Code to ZZZ.999 for ICD10

 ;

 ;This routine stuffs the Dx Code or CPT Code if the 27th Piece

 ;of the RCIS SITE PARAMETERS FILE request these fields to be automatically stuffed.

 ;

START ;Begin Looping through stuffed dx's

 S BMCQ=0

 F  D STUFFDX,ANOTHER Q:BMCQ

 D XIT

 Q

 ;

STUFFDX ;Adds DX  as .9999 if Site Parameters = Yes

 S BMCRDX=""

 ;BMC*4.0*9 added ICD-10 TEST

 ;F  S BMCRDX=$O(^ICD9("AB",".9999",BMCRDX)) Q

 ;F  S BMCRDX=$O(^ICD9("AB",".9999 ",BMCRDX)) Q      ;BMC*4.0*8 change ".9999" to ".9999 "

 ;BMC*4.0*9 added ICD-10 TEST

 I BMCDOS>(BMCDX10-1) S BMCRDX=$O(^ICD9("AB","ZZZ.999 ",BMCRDX))

 E  S BMCRDX=$O(^ICD9("AB",".9999 ",BMCRDX))

 I BMCRDX="" Q

 ;BMC*4.0*9 REMOVED "`" FR X,DIADD AND CHANGED DIC TO FILE^DICN

 ;S X="`"_BMCRDX,DLAYGO=90001.01,DIADD=1,DIC(0)="L",DIC="^BMCDX(" D ^DIC

 S X=BMCRDX,DLAYGO=90001.01,DIC(0)="L",DIC="^BMCDX(" D FILE^DICN

 ;BMC*4.0*9 CHANGED TEST FROM X="" TO +Y<0

 I +Y<0 W !!,"Error has ocurred..Cannot add ICD Uncoded Diagnosis Code to RCIS DIAGNOSIS File - Call Developer On This Error!!!"

 S BMCDXIEN=+Y

DXDIE ;Prompt for Diagnosis Type & Provider Narrative

 K DIADD

 W !!

 I BMCDXIEN'="" D

 . S BMCLOOK=1

 . S BMCDXT="P"

 . S DIE="^BMCDX(",DA=BMCDXIEN,DR="[BMC STUFF DX]"

 . D DIE^BMCFMC

 . K BMCLOOK

 . S:'$G(BMCDX) BMCQ=1

 . K BMCDX

 Q

 ;

ANOTHER ;Ask if User wants to enter Another Dx

 S BMCQ=0

 W !!

 S DIR("A")="Continue entering DX's",DIR("B")="N",DIR(0)="Y" D ^DIR

 I $D(DIRUT) S X="N"

 I Y=0 S BMCQ=1

 S:"Nn"[X BMCQ=1

 W !

 K DIR,DIRUT,DUOUT,DTOUT,DIROUT

 Q

 ;

XIT ;Exit this Loop - go back to BMCADD1

 ;

 Q

BMCDXSTF  ; IHS/PHXAO/TMJ - Stuff Dx & CPT if Site Parameters Request stuffing ;   

 +1       ;;4.0;REFERRED CARE INFO SYSTEM;**8,9**;JAN 09, 2006;Build 101

 +2       ;IHS/ITSC/FCJ Killed DIADD var, was not allowing

 +3       ;       lookup on the Prov. Nar file

 +4       ;BMC*4.0*8 CSV added a space to the .9999 code now checking for ".9999 " for ICD9

 +5       ;BMC*4.0*9 modified to .9999 Code to ZZZ.999 for ICD10

 +6       ;

 +7       ;This routine stuffs the Dx Code or CPT Code if the 27th Piece

 +8       ;of the RCIS SITE PARAMETERS FILE request these fields to be automatically stuffed.

 +9       ;

START     ;Begin Looping through stuffed dx's

 +1        SET BMCQ=0

 +2        FOR 

               DO STUFFDX

               DO ANOTHER

               IF BMCQ

                   QUIT 

 +3        DO XIT

 +4        QUIT 

 +5       ;

STUFFDX   ;Adds DX  as .9999 if Site Parameters = Yes

 +1        SET BMCRDX=""

 +2       ;BMC*4.0*9 added ICD-10 TEST

 +3       ;F  S BMCRDX=$O(^ICD9("AB",".9999",BMCRDX)) Q

 +4       ;F  S BMCRDX=$O(^ICD9("AB",".9999 ",BMCRDX)) Q      ;BMC*4.0*8 change ".9999" to ".9999 "

 +5       ;BMC*4.0*9 added ICD-10 TEST

 +6        IF BMCDOS>(BMCDX10-1)

               SET BMCRDX=$ORDER(^ICD9("AB","ZZZ.999 ",BMCRDX))

 +7       IF '$TEST

               SET BMCRDX=$ORDER(^ICD9("AB",".9999 ",BMCRDX))

 +8        IF BMCRDX=""

               QUIT 

 +9       ;BMC*4.0*9 REMOVED "`" FR X,DIADD AND CHANGED DIC TO FILE^DICN

 +10      ;S X="`"_BMCRDX,DLAYGO=90001.01,DIADD=1,DIC(0)="L",DIC="^BMCDX(" D ^DIC

 +11       SET X=BMCRDX

           SET DLAYGO=90001.01

           SET DIC(0)="L"

           SET DIC="^BMCDX("

           DO FILE^DICN

 +12      ;BMC*4.0*9 CHANGED TEST FROM X="" TO +Y<0

 +13       IF +Y<0

               WRITE !!,"Error has ocurred..Cannot add ICD Uncoded Diagnosis Code to RCIS DIAGNOSIS File - Call Developer On This Error!!!"

 +14       SET BMCDXIEN=+Y

DXDIE     ;Prompt for Diagnosis Type & Provider Narrative

 +1        KILL DIADD

 +2        WRITE !!

 +3        IF BMCDXIEN'=""

               Begin DoDot:1

 +4                SET BMCLOOK=1

 +5                SET BMCDXT="P"

 +6                SET DIE="^BMCDX("

                   SET DA=BMCDXIEN

                   SET DR="[BMC STUFF DX]"

 +7                DO DIE^BMCFMC

 +8                KILL BMCLOOK

 +9                IF '$GET(BMCDX)

                       SET BMCQ=1

 +10               KILL BMCDX

               End DoDot:1

 +11       QUIT 

 +12      ;

ANOTHER   ;Ask if User wants to enter Another Dx

 +1        SET BMCQ=0

 +2        WRITE !!

 +3        SET DIR("A")="Continue entering DX's"

           SET DIR("B")="N"

           SET DIR(0)="Y"

           DO ^DIR

 +4        IF $DATA(DIRUT)

               SET X="N"

 +5        IF Y=0

               SET BMCQ=1

 +6        IF "Nn"[X

               SET BMCQ=1

 +7        WRITE !

 +8        KILL DIR,DIRUT,DUOUT,DTOUT,DIROUT

 +9        QUIT 

 +10      ;

XIT       ;Exit this Loop - go back to BMCADD1

 +1       ;

 +2        QUIT