Routine: BMCFDR2

BMCFDR2 ; IHS/ITSC/FCJ - DRIVER TO PRINT SECONDARY REFERRAL LETTER ;       [ 09/26/2006  4:01 PM ]

 ;;4.0;REFERRED CARE INFO SYSTEM;**2,3**;JAN 09, 2006;Build 101

 ;IHS/OIT/FCJ ADD LINE TO TEST FOR CLOSING SLAVE DEVICE

 ;ALSO ADDED CHECK FOR CHS STATUS AND UPDATE OPTION

 ;4.0*2 9-21-06 IHS/OIT/FCJ ASK TO PRNT CONSULT LETTER

 ;4.0*3 4.19.07 IHS/OIT/FCJ BMCCHSA IS A PARM VAR CHG TO BMCCHSAS

 ;This is the Main Driver Routine -

 ;RCIS REPORT OUTPUT DEFINITION - SECONDARY PROVIDER LETTER

 ;Calls PRINT ROUTINE BMCFPRN2

 ;Rewrote from original version no longer requires data entry

 ;4.0 All call now to BMCREF instead of BMCPROV, ask for prining of

 ;    Prim ref HX and findings

 ;    Added option to update CHS status

START ;

 S BMCCPRV="",BMCAPDT="",BMCAPUR="",BMCDDT="",BMCDPUR=""

 W:$D(IOF) @IOF

 W "**********  REFERRAL FORM PRINT-SECONDARY PROVIDER  **********",!!

 W "This report will produce a hard copy computer generated",!,"Secondary Provider Letter",!

 S BMCQUIT=0

 S BMCCPRV="" ;Secondary Provider Name

 S BMCCPRVS="" ;Secondary Provider Specific

 S BMCAPPDT="" ;Secondary Provider Appointment Date

 S BMCAPUR="" ;Secondary Provider Purpose of Appointment

GETREF ;get referral entry

 S BMCKIND=0 ; Determines If Type = IHS

 S DIR(0)="S^1:STANDARD;2:AHCCCS",DIR("A")="Enter Secondary Letter Type",DIR("B")="STANDARD",DIR("?")="Enter Letter Form Output Choice" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) G XIT

 S BMCHOICE=Y

 S BMCFTYPE=$S(BMCHOICE=1:4,BMCHOICE=2:6,1:4)

 W ! S DIR(0)="Y",DIR("A")="Do you want to include Primary referral History and Findings",DIR("B")="Y" D ^DIR K DIR Q:$D(DUOUT)

 S BMCPHX=+Y

 W !! S BMCREF=""

 S DIC="^BMCREF(",DIC(0)="AEMQ",DIC("A")="Select REFERRAL by Patient or by Referral Date or #: "

 S DIC("S")="I $$FILTER^BMCFLTR(0,0,1)"

 D DIC^BMCFMC

 G:Y=-1 XIT

 S (BMCREF,BMCDTIEN,BMCSRIEN)=+Y

 I $D(^BMCTFORM(BMCFTYPE,11)) X ^BMCTFORM(BMCFTYPE,11) G:BMCQUIT GETREF

CHS I $P($G(^BMCREF(BMCSRIEN,0)),U,4)="C" D

 .;BMC*4.0 4.19.07 IHS/OIT/FCJ BMCCHSA IS A PARM VAR CHG NXT 3 LNS TO BMCCHSAS

 .S BMCCHSAS=$P($G(^BMCREF(BMCSRIEN,11)),U,12)

 .S BMCCHSAP=$$EXTSET^XBFUNC(90001,1112,BMCCHSAS)

 .I BMCCHSAS="" S BMCCHSAP="UNKNOWN"

 .W !!,?10,"**CHS APPROVAL STATUS**: ",BMCCHSAP,!!

 .;Ask if Edit CHS Approval Status

 .S DIR(0)="Y",DIR("A")="Do you wish to Change the Existing CHS Approval Status",DIR("?")="Enter Y for Yes or N for NO",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 .Q:$D(DIRUT)

 .Q:Y=0

 .D CHSSTAT^BMCFDRC

 G:$D(DIRUT) XIT

 S (BMCRIEN,BMCREF)=$P(^BMCREF(BMCSRIEN,1),U,2)

IHS ;IHS Type - Get IHS Facility

 I $P($G(^BMCREF(BMCSRIEN,0)),U,4)="I" D

 .S BMCCPRV=$P($G(^BMCREF(BMCSRIEN,0)),U,8) D

 .S BMCCPRVP=$P($G(^DIC(4,BMCCPRV,0)),U)

 .S BMCKIND=1

GETPROV ;CHS Secondary Provider/Vendor

 S BMCCPRV=$P($G(^BMCREF(BMCSRIEN,0)),U,7)

 S:BMCCPRV BMCCPRVP=$P($G(^AUTTVNDR(BMCCPRV,0)),U)

 I $P(^BMCREF(BMCSRIEN,0),U,9) S BMCCPRVS=$$VAL^XBDIQ1(90001.53,$P(^BMCREF(BMCSRIEN,0),U,9),.01)

APPTDT ;Appointment Date

 S BMCAPPDT=$P(^BMCREF(BMCSRIEN,11),U,6)

PUR ;Purpose of Appointment

 S BMCAPUR=$P(^BMCREF(BMCSRIEN,12),U)

ASKCON ;ASK TO PRINT CONSULT LETTER ;BMC*4.0*2 IHS/OIT/FCJ

 D ASKCON^BMCFDR

ZIS ;

 W !! S XBRC="COMP^BMCFDR2",XBRP="PRINT^BMCFDR2",XBNS="BMC",XBRX="XIT^BMCFDR2"

 D ^XBDBQUE

PRINT ;EP

 X:$D(^BMCTFORM(BMCFTYPE,12)) ^BMCTFORM(BMCFTYPE,12)

XIT ;

 K BMCCAP,BMCCHSR,BMCDA,BMCFILE,BMCFTYPE,BMCIOM,BMCKPDA,BMCNODE,BMCPG,BMCQUIT,BMCR0,BMCREF,BMCRNS,BMCV,BMCWP,BMCX,BMCY,BMCI,BMCDFN

 K A,C,D,D0,D1,DA,DD,DDSFILE,DI,DIADD,DIC,DICR,DIE,DIK,DINUM,DIPGM,DIQ,DIR,DIWF,DIWL,DIWR,DLAYGO,DO,DQ,DR,DTOUT,F,G,I,J,N,P,T,X,Y,Z

 K BMCPROUT,BMCN,BMCNUM,BMCAGE,BMCFIRST,BMCLAST,BMCLTYP,BMCDTIEN,BMCCPRV,BMCAPPDT,BMCAPUR,BMCDTIEN,BMCCHSAP,BMCCHSAS

 K BMCAPDT,BMCHOICE,BMCKIND,BMCTYPE,BMCDDT,BMCDPUR,BMCCMT,BMCCPRVP,BMCCPRVS,BMCDT,BMCRIEN,BMCSRIEN,BMCR1,BMCPHX

 I $D(IO("S")) S IOP="`"_IOS D ^%ZIS

COMP ;

WP ;EP - Entry point to print wp fields pass node in BMCWP

 ;PASS FILE IN BMCFILE, ENTRY IN BMCREF

 NEW G,P,BMCX

 K BMCWP

 K ^UTILITY($J,"W")

 S BMCX=0,P=0

 S G=$S($G(G)]"":G,1:^DIC(BMCFILE,0,"GL")),G=G_BMCDA_","_BMCNODE_",BMCX)"

 S DIWR=$S($G(BMCIOM):BMCIOM,1:IOM),DIWL=0 F  S BMCX=$O(@G) Q:BMCX'=+BMCX  D

 .S Y=$P(G,")")_",0)"

 .S X="" I $G(BMCCAP)]"",BMCX=1 S X=BMCCAP

 .S X=X_@Y D ^DIWP

.Q

WPS ;EP

 S Z=0 F  S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z  S P=P+1,BMCWP(P)=^UTILITY($J,"W",DIWL,Z,0)

 K DIWL,DIWR,DIWF,Z

 K ^UTILITY($J,"W"),BMCNODE,BMCFILE,BMCDA,G,BMCCOL,BMCCAP

BMCFDR2   ; IHS/ITSC/FCJ - DRIVER TO PRINT SECONDARY REFERRAL LETTER ;       [ 09/26/2006  4:01 PM ]

 +1       ;;4.0;REFERRED CARE INFO SYSTEM;**2,3**;JAN 09, 2006;Build 101

 +2       ;IHS/OIT/FCJ ADD LINE TO TEST FOR CLOSING SLAVE DEVICE

 +3       ;ALSO ADDED CHECK FOR CHS STATUS AND UPDATE OPTION

 +4       ;4.0*2 9-21-06 IHS/OIT/FCJ ASK TO PRNT CONSULT LETTER

 +5       ;4.0*3 4.19.07 IHS/OIT/FCJ BMCCHSA IS A PARM VAR CHG TO BMCCHSAS

 +6       ;

 +7       ;This is the Main Driver Routine -

 +8       ;RCIS REPORT OUTPUT DEFINITION - SECONDARY PROVIDER LETTER

 +9       ;Calls PRINT ROUTINE BMCFPRN2

 +10      ;Rewrote from original version no longer requires data entry

 +11      ;4.0 All call now to BMCREF instead of BMCPROV, ask for prining of

 +12      ;    Prim ref HX and findings

 +13      ;    Added option to update CHS status

 +14      ;

START     ;

 +1        SET BMCCPRV=""

           SET BMCAPDT=""

           SET BMCAPUR=""

           SET BMCDDT=""

           SET BMCDPUR=""

 +2        IF $DATA(IOF)

               WRITE @IOF

 +3        WRITE "**********  REFERRAL FORM PRINT-SECONDARY PROVIDER  **********",!!

 +4        WRITE "This report will produce a hard copy computer generated",!,"Secondary Provider Letter",!

 +5        SET BMCQUIT=0

 +6       ;Secondary Provider Name

           SET BMCCPRV=""

 +7       ;Secondary Provider Specific

           SET BMCCPRVS=""

 +8       ;Secondary Provider Appointment Date

           SET BMCAPPDT=""

 +9       ;Secondary Provider Purpose of Appointment

           SET BMCAPUR=""

GETREF    ;get referral entry

 +1       ; Determines If Type = IHS

           SET BMCKIND=0

 +2        SET DIR(0)="S^1:STANDARD;2:AHCCCS"

           SET DIR("A")="Enter Secondary Letter Type"

           SET DIR("B")="STANDARD"

           SET DIR("?")="Enter Letter Form Output Choice"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               GOTO XIT

 +4        SET BMCHOICE=Y

 +5        SET BMCFTYPE=$SELECT(BMCHOICE=1:4,BMCHOICE=2:6,1:4)

 +6        WRITE !

           SET DIR(0)="Y"

           SET DIR("A")="Do you want to include Primary referral History and Findings"

           SET DIR("B")="Y"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               QUIT

 +7        SET BMCPHX=+Y

 +8        WRITE !!

           SET BMCREF=""

 +9        SET DIC="^BMCREF("

           SET DIC(0)="AEMQ"

           SET DIC("A")="Select REFERRAL by Patient or by Referral Date or #: "

 +10       SET DIC("S")="I $$FILTER^BMCFLTR(0,0,1)"

 +11       DO DIC^BMCFMC

 +12       IF Y=-1

               GOTO XIT

 +13       SET (BMCREF,BMCDTIEN,BMCSRIEN)=+Y

 +14       IF $DATA(^BMCTFORM(BMCFTYPE,11))

               XECUTE ^BMCTFORM(BMCFTYPE,11)

               IF BMCQUIT

                   GOTO GETREF

CHS        IF $PIECE($GET(^BMCREF(BMCSRIEN,0)),U,4)="C"

               Begin DoDot:1

 +1       ;BMC*4.0 4.19.07 IHS/OIT/FCJ BMCCHSA IS A PARM VAR CHG NXT 3 LNS TO BMCCHSAS

 +2                SET BMCCHSAS=$PIECE($GET(^BMCREF(BMCSRIEN,11)),U,12)

 +3                SET BMCCHSAP=$$EXTSET^XBFUNC(90001,1112,BMCCHSAS)

 +4                IF BMCCHSAS=""

                       SET BMCCHSAP="UNKNOWN"

 +5                WRITE !!,?10,"**CHS APPROVAL STATUS**: ",BMCCHSAP,!!

 +6       ;Ask if Edit CHS Approval Status

 +7                SET DIR(0)="Y"

                   SET DIR("A")="Do you wish to Change the Existing CHS Approval Status"

                   SET DIR("?")="Enter Y for Yes or N for NO"

                   SET DIR("B")="N"

                   DO ^DIR

                   KILL DIR

                   IF $DATA(DUOUT)

                       SET DIRUT=1

 +8                IF $DATA(DIRUT)

                       QUIT

 +9                IF Y=0

                       QUIT

 +10               DO CHSSTAT^BMCFDRC

               End DoDot:1

 +11       IF $DATA(DIRUT)

               GOTO XIT

 +12       SET (BMCRIEN,BMCREF)=$PIECE(^BMCREF(BMCSRIEN,1),U,2)

 +13      ;

IHS       ;IHS Type - Get IHS Facility

 +1        IF $PIECE($GET(^BMCREF(BMCSRIEN,0)),U,4)="I"

               Begin DoDot:1

 +2                SET BMCCPRV=$PIECE($GET(^BMCREF(BMCSRIEN,0)),U,8)

                   Begin DoDot:2

                   End DoDot:2

 +3                SET BMCCPRVP=$PIECE($GET(^DIC(4,BMCCPRV,0)),U)

 +4                SET BMCKIND=1

               End DoDot:1

 +5       ;

 +6       ;

GETPROV   ;CHS Secondary Provider/Vendor

 +1        SET BMCCPRV=$PIECE($GET(^BMCREF(BMCSRIEN,0)),U,7)

 +2        IF BMCCPRV

               SET BMCCPRVP=$PIECE($GET(^AUTTVNDR(BMCCPRV,0)),U)

 +3        IF $PIECE(^BMCREF(BMCSRIEN,0),U,9)

               SET BMCCPRVS=$$VAL^XBDIQ1(90001.53,$PIECE(^BMCREF(BMCSRIEN,0),U,9),.01)

 +4       ;

APPTDT    ;Appointment Date

 +1        SET BMCAPPDT=$PIECE(^BMCREF(BMCSRIEN,11),U,6)

 +2       ;

PUR       ;Purpose of Appointment

 +1        SET BMCAPUR=$PIECE(^BMCREF(BMCSRIEN,12),U)

 +2       ;

ASKCON    ;ASK TO PRINT CONSULT LETTER ;BMC*4.0*2 IHS/OIT/FCJ

 +1        DO ASKCON^BMCFDR

ZIS       ;

 +1        WRITE !!

           SET XBRC="COMP^BMCFDR2"

           SET XBRP="PRINT^BMCFDR2"

           SET XBNS="BMC"

           SET XBRX="XIT^BMCFDR2"

 +2        DO ^XBDBQUE

 +3        QUIT

 +4       ;

PRINT     ;EP

 +1        IF $DATA(^BMCTFORM(BMCFTYPE,12))

               XECUTE ^BMCTFORM(BMCFTYPE,12)

 +2        QUIT

XIT       ;

 +1        KILL BMCCAP,BMCCHSR,BMCDA,BMCFILE,BMCFTYPE,BMCIOM,BMCKPDA,BMCNODE,BMCPG,BMCQUIT,BMCR0,BMCREF,BMCRNS,BMCV,BMCWP,BMCX,BMCY,BMCI,BMCDFN

 +2        KILL A,C,D,D0,D1,DA,DD,DDSFILE,DI,DIADD,DIC,DICR,DIE,DIK,DINUM,DIPGM,DIQ,DIR,DIWF,DIWL,DIWR,DLAYGO,DO,DQ,DR,DTOUT,F,G,I,J,N,P,T,X,Y,Z

 +3        KILL BMCPROUT,BMCN,BMCNUM,BMCAGE,BMCFIRST,BMCLAST,BMCLTYP,BMCDTIEN,BMCCPRV,BMCAPPDT,BMCAPUR,BMCDTIEN,BMCCHSAP,BMCCHSAS

 +4        KILL BMCAPDT,BMCHOICE,BMCKIND,BMCTYPE,BMCDDT,BMCDPUR,BMCCMT,BMCCPRVP,BMCCPRVS,BMCDT,BMCRIEN,BMCSRIEN,BMCR1,BMCPHX

 +5        IF $DATA(IO("S"))

               SET IOP="`"_IOS

               DO ^%ZIS

 +6        QUIT

COMP      ;

 +1        QUIT

WP        ;EP - Entry point to print wp fields pass node in BMCWP

 +1       ;PASS FILE IN BMCFILE, ENTRY IN BMCREF

 +2        NEW G,P,BMCX

 +3        KILL BMCWP

 +4        KILL ^UTILITY($JOB,"W")

 +5        SET BMCX=0

           SET P=0

 +6        SET G=$SELECT($GET(G)]"":G,1:^DIC(BMCFILE,0,"GL"))

           SET G=G_BMCDA_","_BMCNODE_",BMCX)"

 +7        SET DIWR=$SELECT($GET(BMCIOM):BMCIOM,1:IOM)

           SET DIWL=0

FOR

               SET BMCX=$ORDER(@G)

               IF BMCX'=+BMCX

                   QUIT

               Begin DoDot:1

 +8                SET Y=$PIECE(G,")")_",0)"

 +9                SET X=""

                   IF $GET(BMCCAP)]""

                       IF BMCX=1

                           SET X=BMCCAP

 +10               SET X=X_@Y

                   DO ^DIWP

 +11               QUIT

               End DoDot:1

WPS       ;EP

 +1        SET Z=0

FOR

               SET Z=$ORDER(^UTILITY($JOB,"W",DIWL,Z))

               IF Z'=+Z

                   QUIT

               SET P=P+1

               SET BMCWP(P)=^UTILITY($JOB,"W",DIWL,Z,0)

 +2        KILL DIWL,DIWR,DIWF,Z

 +3        KILL ^UTILITY($JOB,"W"),BMCNODE,BMCFILE,BMCDA,G,BMCCOL,BMCCAP

 +4        QUIT

BMCFDR2.m