Routine: BMCPXSTF

BMCPXSTF ; IHS/PHXAO/TMJ - Stuff CPT if Site Parameters Request stuffing ;

 ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006

 ;IHS/ITSC/FCJ Killed DIADD var, was not allowing entry on the Prc Nar

 ;This routine stuffs the CPT Procedure Code if the 27th Piece

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

START ;Begin Looping through stuffed PX's

 S BMCQ=0

 F  D STUFFPX,ANOTHER Q:BMCQ

 D XIT

STUFFPX ;Adds PX  as 00999 if Site Parameters = Yes

 S BMCRPX=""

 F  S BMCRPX=$O(^ICPT("B","00099",BMCRPX)) Q

 I BMCRPX="" Q

 S X="`"_BMCRPX,DLAYGO=90001.02,DIADD=1,DIC(0)="L",DIC="^BMCPX(" D ^DIC

 I X="" W !!,"Error has ocurred..Cannot Add a 00099 CPT Code to RCIS PROCEDURE File - Call Developer On This Error!!!"

 S BMCPXIEN=+Y

PXDIE ;Prompt for CPT Type & Provider Narrative

 K DIADD

 W !!

 I BMCPXIEN'="" D

 . S BMCLOOK=1

 . S BMCPXT="P"

 . S DIE="^BMCPX(",DA=BMCPXIEN,DR="[BMC STUFF PX]"

 . D DIE^BMCFMC

 . K BMCLOOK

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

 . K BMCPX

ANOTHER ;Ask if User wants to enter Another Dx

 S BMCQ=0

 W !!

 S DIR("A")="Continue entering PX'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

XIT ;Exit this Loop - go back to BMCADD1

BMCPXSTF  ; IHS/PHXAO/TMJ - Stuff CPT if Site Parameters Request stuffing ;

 +1       ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006

 +2       ;IHS/ITSC/FCJ Killed DIADD var, was not allowing entry on the Prc Nar

 +3       ;

 +4       ;This routine stuffs the CPT Procedure Code if the 27th Piece

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

 +6       ;

START     ;Begin Looping through stuffed PX's

 +1        SET BMCQ=0

 +2        FOR

               DO STUFFPX

               DO ANOTHER

               IF BMCQ

                   QUIT

 +3        DO XIT

 +4        QUIT

 +5       ;

STUFFPX   ;Adds PX  as 00999 if Site Parameters = Yes

 +1        SET BMCRPX=""

 +2        FOR

               SET BMCRPX=$ORDER(^ICPT("B","00099",BMCRPX))

               QUIT

 +3        IF BMCRPX=""

               QUIT

 +4        SET X="`"_BMCRPX

           SET DLAYGO=90001.02

           SET DIADD=1

           SET DIC(0)="L"

           SET DIC="^BMCPX("

           DO ^DIC

 +5        IF X=""

               WRITE !!,"Error has ocurred..Cannot Add a 00099 CPT Code to RCIS PROCEDURE File - Call Developer On This Error!!!"

 +6        SET BMCPXIEN=+Y

PXDIE     ;Prompt for CPT Type & Provider Narrative

 +1        KILL DIADD

 +2        WRITE !!

 +3        IF BMCPXIEN'=""

               Begin DoDot:1

 +4                SET BMCLOOK=1

 +5                SET BMCPXT="P"

 +6                SET DIE="^BMCPX("

                   SET DA=BMCPXIEN

                   SET DR="[BMC STUFF PX]"

 +7                DO DIE^BMCFMC

 +8                KILL BMCLOOK

 +9                IF '$GET(BMCPX)

                       SET BMCQ=1

 +10               KILL BMCPX

               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 PX'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

BMCPXSTF.m