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
