BMCFDR.m

BMCFDR ; IHS/PHXAO/TMJ - DRIVER TO PRINT REFERRAL FORM ;        [ 09/26/2006  3:57 PM ]

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

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

 ;IHS/OIT/FCJ REMOVED CHSSTAT SECTION

 ;4.0*2 9.14.06 IHS.OIT.FCJ ADDED SECTION TO PRINT CONSULT LTR

 ;4.0*3 12.10.2007 IHS.OIT.FCJ ADDED EP LABEL TO ASKCON LINE

 ;4.0*5 3.29.2009 IHS.OIT.FCJ ROUTING SLIP WAS NOT PRINTING W/REF

START ;

 W:$D(IOF) @IOF

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

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

 S BMCQUIT=0,BMCPCON=0

GETTYPE ;Get Type of Referral-Screen Out Secondary Provider Letter

 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

 I ($P(Y,U,2)="STANDARD IHS REFERRAL LETTER")!($E($P(Y,U,2),1,7)="CALL-IN") S BMCPCON=1

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)"

 S DIC("S")="I $$FILTER^BMCFLTR(3,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

 ;

ASKROUT ;Ask if Want to Print Routing Slip if Exists

 S BMCPROUT=0

 ;BMC*4.0*2 9.14.06 IHS.OIT.FCJ CHANGED G TO LINE REFERENCE

 ;G:'$D(^BMCREF(BMCREF,4))&('$D(^BMCREF(BMCREF,5))) ZIS

 I '$D(^BMCREF(BMCREF,4))&('$D(^BMCREF(BMCREF,5))) D ASKCON G ZIS

 ;

 W !!,?10,"**ROUTING SLIP INFORMATION IS ATTACHED TO THIS REFERRAL**"

 W !!

 S DIR(0)="Y",DIR("A")="Do you wish to also Print the Routing Slip NOW",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

 ;BMC*4.0*2 9.14.06 IHS.OIT.FCJ CHANGED G TO LINE REFERENCE

 ;I Y=0 G ZIS

 S:Y'=0 BMCPROUT=1 D ASKCON G ZIS

 ;BMC*4.0*2 9.14.06 IHS.OIT.FCJ ADDED NXT SECTION TO PRINT CONSULT LTR

ASKCON ;EP;Ask to print consult

 Q:$G(BMCPCON)=0

 S BMCPCON=0 I $P($G(^BMCPARM(DUZ(2),4100)),U,8)="Y" D

 .W !!

 .S DIR(0)="Y",DIR("B")="Y"

 .S DIR("A")="Do you wish to also Print the Consult Letter NOW"

 .D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 .Q:Y=0  S BMCPCON=1

 Q

 ;BMC*4.0*2 9.14.06 IHS.OIT.FCJ END OF CHANGES

ZIS ;

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

 D ^XBDBQUE

 Q

 ;

PRINT ;EP

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

 Q

XIT ;

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

 K A,C,D,D0,D1,DA,DD,DDSFILE,DI,DIADD,DIC,DICR,DIE,DIK,DINUM,DIPGM,DIQ,DIR,DIW,DIWI,DIWT,DIWTC,DIWX,DIWF,DIWL,DIWR,DLAYGO,DO,DQ,DR,DTOUT

 K F,G,I,J,N,P,T,X,Y,Z

 K BMCPCON,BMCPROUT,BMCN,BMCNI,BMCNUM,BMCVIEN

 K BMCCHSCT,BMCCMT,BMCRDATE,BMCREC,BMCRIEN,BMCRIO,BMCRNUMB,BMCRSTAT,BMCRTYPE,BMCVST,BMCVSTP

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

 Q

COMP ;

 Q

CHSSTAT ;

 Q

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

 Q

AHCCCS ;EP

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

 Q

BMCFDR    ; IHS/PHXAO/TMJ - DRIVER TO PRINT REFERRAL FORM ;        [ 09/26/2006  3:57 PM ]

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

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

 +3       ;IHS/OIT/FCJ REMOVED CHSSTAT SECTION

 +4       ;4.0*2 9.14.06 IHS.OIT.FCJ ADDED SECTION TO PRINT CONSULT LTR

 +5       ;4.0*3 12.10.2007 IHS.OIT.FCJ ADDED EP LABEL TO ASKCON LINE

 +6       ;4.0*5 3.29.2009 IHS.OIT.FCJ ROUTING SLIP WAS NOT PRINTING W/REF

START     ;

 +1        IF $DATA(IOF)

               WRITE @IOF

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

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

 +4        SET BMCQUIT=0

           SET BMCPCON=0

GETTYPE   ;Get Type of Referral-Screen Out Secondary Provider Letter

 +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

 +5        IF ($PIECE(Y,U,2)="STANDARD IHS REFERRAL LETTER")!($EXTRACT($PIECE(Y,U,2),1,7)="CALL-IN")

               SET BMCPCON=1

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       ;S DIC("S")="I $$FILTER^BMCFLTR(0,0,0)"

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

 +5        DO ^DIC

           KILL DA,DIC

 +6        IF Y=-1

               GOTO XIT

 +7        SET BMCREF=+Y

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

               XECUTE ^BMCTFORM(BMCFTYPE,11)

               IF BMCQUIT

                   GOTO GETREF

 +9       ;

ASKROUT   ;Ask if Want to Print Routing Slip if Exists

 +1        SET BMCPROUT=0

 +2       ;BMC*4.0*2 9.14.06 IHS.OIT.FCJ CHANGED G TO LINE REFERENCE

 +3       ;G:'$D(^BMCREF(BMCREF,4))&('$D(^BMCREF(BMCREF,5))) ZIS

 +4        IF '$DATA(^BMCREF(BMCREF,4))&('$DATA(^BMCREF(BMCREF,5)))

               DO ASKCON

               GOTO ZIS

 +5       ;

 +6        WRITE !!,?10,"**ROUTING SLIP INFORMATION IS ATTACHED TO THIS REFERRAL**"

 +7        WRITE !!

 +8        SET DIR(0)="Y"

           SET DIR("A")="Do you wish to also Print the Routing Slip NOW"

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

           SET DIR("B")="N"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +9        IF $DATA(DIRUT)

               GOTO XIT

 +10      ;BMC*4.0*2 9.14.06 IHS.OIT.FCJ CHANGED G TO LINE REFERENCE

 +11      ;I Y=0 G ZIS

 +12       IF Y'=0

               SET BMCPROUT=1

           DO ASKCON

           GOTO ZIS

 +13      ;BMC*4.0*2 9.14.06 IHS.OIT.FCJ ADDED NXT SECTION TO PRINT CONSULT LTR

ASKCON    ;EP;Ask to print consult

 +1        IF $GET(BMCPCON)=0

               QUIT 

 +2        SET BMCPCON=0

           IF $PIECE($GET(^BMCPARM(DUZ(2),4100)),U,8)="Y"

               Begin DoDot:1

 +3                WRITE !!

 +4                SET DIR(0)="Y"

                   SET DIR("B")="Y"

 +5                SET DIR("A")="Do you wish to also Print the Consult Letter NOW"

 +6                DO ^DIR

                   KILL DIR

                   IF $DATA(DUOUT)

                       SET DIRUT=1

 +7                IF Y=0

                       QUIT 

                   SET BMCPCON=1

               End DoDot:1

 +8        QUIT 

 +9       ;BMC*4.0*2 9.14.06 IHS.OIT.FCJ END OF CHANGES

ZIS       ;

 +1        WRITE !!

           SET XBRC="COMP^BMCFDR"

           SET XBRP="PRINT^BMCFDR"

           SET XBNS="BMC"

           SET XBRX="XIT^BMCFDR"

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

 +2        KILL A,C,D,D0,D1,DA,DD,DDSFILE,DI,DIADD,DIC,DICR,DIE,DIK,DINUM,DIPGM,DIQ,DIR,DIW,DIWI,DIWT,DIWTC,DIWX,DIWF,DIWL,DIWR,DLAYGO,DO,DQ,DR,DTOUT

 +3        KILL F,G,I,J,N,P,T,X,Y,Z

 +4        KILL BMCPCON,BMCPROUT,BMCN,BMCNI,BMCNUM,BMCVIEN

 +5        KILL BMCCHSCT,BMCCMT,BMCRDATE,BMCREC,BMCRIEN,BMCRIO,BMCRNUMB,BMCRSTAT,BMCRTYPE,BMCVST,BMCVSTP

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

               SET IOP="`"_IOS

               DO ^%ZIS

 +7        QUIT 

COMP      ;

 +1        QUIT 

CHSSTAT   ;

 +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 

AHCCCS    ;EP

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

 +2        QUIT