Routine: BMCFDRC

BMCFDRC ; IHS/PHXAO/TMJ - CHS DRIVER TO PRINT REFERRAL FORM ;       [ 09/26/2006  4:01 PM ]

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

 ;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

 ;4.0*4 2.25.2008 IHS/OIT/FCJ TEST FOR CONSULT PARAMETER

START ;

 S BMCPROUT=0

 W:$D(IOF) @IOF

 W "**********  REFERRAL FORM PRINT  **********",!!

 W "This report will produce a hard copy computer generated referral letter.",!

 S BMCQUIT=0

GETTYPE ;

 S BMCFTYPE=""

 S DIC="^BMCTFORM(",DIC(0)="AEMQ",DIC("S")="I $D(^(0)),$P(^(0),U)'[""SECOND"",$P(^(0),U)'[""ALT""",DIC("A")="Select Type of Letter to be printed: " D ^DIC K DA,DIC

 G:Y=-1 XIT

 S BMCFTYPE=+Y

GETREF ;get referral entry

 W !! S BMCREF=""

 S DIC="^BMCREF(",DIC(0)="AEMQ",DIC("A")="Select Referral by Patient Name, date of referral or referral #: "

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

 D ^DIC K DA,DIC

 G:Y=-1 XIT

 S BMCREF=+Y

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

 ;BMC*4.0*4 2/25/2008 IHS/OIT/FCJ CHANGED NXT 2 LINES TO TEST FOR PRINTING CONSULT LTR

 ;G:BMCFTYPE'=1 ZIS

 ;G:$P($G(^BMCREF(BMCREF,0)),U,4)'="C" ZIS

 G:BMCFTYPE'=1 ASKCON

 G:$P($G(^BMCREF(BMCREF,0)),U,4)'="C" ASKCON

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

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

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

 I BMCCHSAS="" S BMCCHSAP="UNKNOWN"

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

CHSASK ;Ask if Edit CHS Approval Status

 W !!

 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

 I $D(DIRUT) G XIT

 I Y=0 G ASKCON

 D CHSSTAT

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

 D ASKCON^BMCFDR

ZIS ;

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

 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,BMCCHSAS,BMCCHSAP

 K BMCCHSCT,BMCCHSS,BMCCMT,BMCDN,BMCI,BMCN,BMCNI,BMCNUM,BMCPROUT,BMCQ,BMCPG,BMCVST,BMCVSTP,DFN,BMCVIEN

 K BMCR0,BMCRDATE,BMCREC,BMCRIEN,BMCRNUMB,BMCRSTAT,BMCRTYPE,BMCSUF,BMCRSTAT,BMCRIEN,BMCRNUMB,BMCRSTAT,BMCRTYPE,BMCSUF,BMCRSTAT

 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

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

CHSSTAT ;EP

W !

 ;Q:BMCFTYPE'=1

 Q:$P(^BMCREF(BMCREF,0),U,4)'="C"

 I $P($G(^BMCREF(BMCREF,11)),U,12)="" W !!,$C(7),$C(7),"The CHS Approval Status has not been entered.  Please enter it now.",!

 S DIE="^BMCREF(",DA=BMCREF,DR=1112 D ^DIE K DIE,DA

 S BMCCHSR=$P($G(^BMCREF(BMCREF,11)),U,12) I BMCCHSR="" S BMCCHSR="1" W !!,"No entry made.  Defaulting to 'PENDING Status for verbiage on Referral Letter'.",!!

AHCCCS ;EP

 W !!,$C(7),$C(7),"This letter must be printed on a printer capable of 132 character print.",!!

BMCFDRC   ; IHS/PHXAO/TMJ - CHS DRIVER TO PRINT REFERRAL FORM ;       [ 09/26/2006  4:01 PM ]

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

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

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

 +4       ;4.0*4 2.25.2008 IHS/OIT/FCJ TEST FOR CONSULT PARAMETER

START     ;

 +1        SET BMCPROUT=0

 +2        IF $DATA(IOF)

               WRITE @IOF

 +3        WRITE "**********  REFERRAL FORM PRINT  **********",!!

 +4        WRITE "This report will produce a hard copy computer generated referral letter.",!

 +5        SET BMCQUIT=0

GETTYPE   ;

 +1        SET BMCFTYPE=""

 +2        SET DIC="^BMCTFORM("

           SET DIC(0)="AEMQ"

           SET DIC("S")="I $D(^(0)),$P(^(0),U)'[""SECOND"",$P(^(0),U)'[""ALT"""

           SET DIC("A")="Select Type of Letter to be printed: "

           DO ^DIC

           KILL DA,DIC

 +3        IF Y=-1

               GOTO XIT

 +4        SET BMCFTYPE=+Y

GETREF    ;get referral entry

 +1        WRITE !!

           SET BMCREF=""

 +2        SET DIC="^BMCREF("

           SET DIC(0)="AEMQ"

           SET DIC("A")="Select Referral by Patient Name, date of referral or referral #: "

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

 +4        DO ^DIC

           KILL DA,DIC

 +5        IF Y=-1

               GOTO XIT

 +6        SET BMCREF=+Y

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

               XECUTE ^BMCTFORM(BMCFTYPE,11)

               IF BMCQUIT

                   GOTO GETREF

 +8       ;BMC*4.0*4 2/25/2008 IHS/OIT/FCJ CHANGED NXT 2 LINES TO TEST FOR PRINTING CONSULT LTR

 +9       ;G:BMCFTYPE'=1 ZIS

 +10      ;G:$P($G(^BMCREF(BMCREF,0)),U,4)'="C" ZIS

 +11       IF BMCFTYPE'=1

               GOTO ASKCON

 +12       IF $PIECE($GET(^BMCREF(BMCREF,0)),U,4)'="C"

               GOTO ASKCON

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

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

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

 +16       IF BMCCHSAS=""

               SET BMCCHSAP="UNKNOWN"

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

 +18      ;

CHSASK    ;Ask if Edit CHS Approval Status

 +1        WRITE !!

 +2        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

 +3        IF $DATA(DIRUT)

               GOTO XIT

 +4        IF Y=0

               GOTO ASKCON

 +5        DO CHSSTAT

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

 +1        DO ASKCON^BMCFDR

ZIS       ;

 +1        WRITE !!

           SET XBRC="COMP^BMCFDRC"

           SET XBRP="PRINT^BMCFDRC"

           SET XBNS="BMC"

           SET XBRX="XIT^BMCFDRC"

 +2        DO ^XBDBQUE

 +3        QUIT

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,BMCCHSAS,BMCCHSAP

 +2        KILL BMCCHSCT,BMCCHSS,BMCCMT,BMCDN,BMCI,BMCN,BMCNI,BMCNUM,BMCPROUT,BMCQ,BMCPG,BMCVST,BMCVSTP,DFN,BMCVIEN

 +3        KILL BMCR0,BMCRDATE,BMCREC,BMCRIEN,BMCRNUMB,BMCRSTAT,BMCRTYPE,BMCSUF,BMCRSTAT,BMCRIEN,BMCRNUMB,BMCRSTAT,BMCRTYPE,BMCSUF,BMCRSTAT

 +4        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

 +5        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

CHSSTAT   ;EP

 +1        WRITE !

 +2       ;Q:BMCFTYPE'=1

 +3        IF $PIECE(^BMCREF(BMCREF,0),U,4)'="C"

               QUIT

 +4        IF $PIECE($GET(^BMCREF(BMCREF,11)),U,12)=""

               WRITE !!,$CHAR(7),$CHAR(7),"The CHS Approval Status has not been entered.  Please enter it now.",!

 +5        SET DIE="^BMCREF("

           SET DA=BMCREF

           SET DR=1112

           DO ^DIE

           KILL DIE,DA

 +6        SET BMCCHSR=$PIECE($GET(^BMCREF(BMCREF,11)),U,12)

           IF BMCCHSR=""

               SET BMCCHSR="1"

               WRITE !!,"No entry made.  Defaulting to 'PENDING Status for verbiage on Referral Letter'.",!!

 +7       ;

 +8        QUIT

AHCCCS    ;EP

 +1        WRITE !!,$CHAR(7),$CHAR(7),"This letter must be printed on a printer capable of 132 character print.",!!

 +2        QUIT

BMCFDRC.m