BMCFDRA ; IHS/PHXAO/TMJ - DRIVER TO PRINT ALT RESOURCE LETTER ;
;;4.0;REFERRED CARE INFO SYSTEM;**4**;JAN 09, 2006;Build 101
START ;
W:$D(IOF) @IOF
W "********** REFERRAL FORM PRINT **********",!!
W "This report will produce a hard copy computer generated Alternate Resource",!,"Application Letter",!
S BMCQUIT=0
GETTYPE ;Select Alternate Resource Contact & set Text Verbiage
S BMCFTYPE=3
S DIC="^BMCALT(",DIC(0)="AEMQ",DIC("A")="Select Letter Contact Point: " D ^DIC K DA,DIC
G:Y=-1 XIT
S BMCCPRV=+Y
S BMCCPRVP=$P($G(^BMCALT(BMCCPRV,0)),U)
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 #: " D ^DIC K DA,DIC
G:Y=-1 XIT
S BMCREF=+Y
I $D(^BMCTFORM(BMCFTYPE,11)) X ^BMCTFORM(BMCFTYPE,11) G:BMCQUIT GETREF
;
;Alt Resource Documentation Information
S DA=BMCREF,DIE="^BMCREF(",DR="1501Enter Appointment Documentation" D ^DIE K DA,DIE,DIU,DIVDR
;
TYPE ;Get Type of Letter Dissemination
S BMCLTYP=""
S DA=BMCREF,DIE="^BMCREF(",DR="1404Select Type of Distribution" D ^DIE K DA,DIE,DIU,DIVDR
;
S BMCLTYP=X
I BMCLTYP'="M" G ZIS
;
;Alt Resource Mail Certified Receipt Number
S DA=BMCREF,DIE="^BMCREF(",DR="1403Enter Certified Mail Receipt" D ^DIE K DA,DIE,DIU,DIVDR
;
ZIS ;
W !! S XBRC="COMP^BMCFDRA",XBRP="PRINT^BMCFDRA",XBNS="BMC",XBRX="XIT^BMCFDRA"
D ^XBDBQUE
Q
;
PRINT ;EP
X:$D(^BMCTFORM(BMCFTYPE,12)) ^BMCTFORM(BMCFTYPE,12)
Q
XIT ;
;BMC*4.0*4 IHS/OIT/FCJ ADDED BMCSIR
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,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,BMCSIR
Q
COMP ;
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
CHSSTAT ;EP
Q:BMCFTYPE'=1
Q ;Quit - No longer ask for CHS Preliminary Review per Stan 8/28/96
Q:$P(^BMCREF(BMCREF,0),U,4)'="C"
I $P($G(^BMCREF(BMCREF,11)),U,20)]"" S BMCCHSR=$P(^BMCREF(BMCREF,11),U,20) Q
W !!,$C(7),$C(7),"The CHS Preliminary Review has not been entered. Please enter it now.",!
S DIE="^BMCREF(",DA=BMCREF,DR=1120 D ^DIE K DIE,DA
S BMCCHSR=$P($G(^BMCREF(BMCREF,11)),U,20) I BMCCHSR="" S BMCCHSR="3" W !!,"No entry made. Defaulting to 'TO BE DETERMINED'.",!!
Q
AHCCCS ;EP
W !!,$C(7),$C(7),"This letter must be printed on a printer capable of 132 character print.",!!
Q
BMCFDRA ; IHS/PHXAO/TMJ - DRIVER TO PRINT ALT RESOURCE LETTER ;
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**4**;JAN 09, 2006;Build 101
START ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE "********** REFERRAL FORM PRINT **********",!!
+3 WRITE "This report will produce a hard copy computer generated Alternate Resource",!,"Application Letter",!
+4 SET BMCQUIT=0
GETTYPE ;Select Alternate Resource Contact & set Text Verbiage
+1 SET BMCFTYPE=3
+2 SET DIC="^BMCALT("
SET DIC(0)="AEMQ"
SET DIC("A")="Select Letter Contact Point: "
DO ^DIC
KILL DA,DIC
+3 IF Y=-1
GOTO XIT
+4 SET BMCCPRV=+Y
+5 SET BMCCPRVP=$PIECE($GET(^BMCALT(BMCCPRV,0)),U)
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 #: "
DO ^DIC
KILL DA,DIC
+3 IF Y=-1
GOTO XIT
+4 SET BMCREF=+Y
+5 IF $DATA(^BMCTFORM(BMCFTYPE,11))
XECUTE ^BMCTFORM(BMCFTYPE,11)
IF BMCQUIT
GOTO GETREF
+6 ;
+7 ;Alt Resource Documentation Information
+8 SET DA=BMCREF
SET DIE="^BMCREF("
SET DR="1501Enter Appointment Documentation"
DO ^DIE
KILL DA,DIE,DIU,DIVDR
+9 ;
TYPE ;Get Type of Letter Dissemination
+1 SET BMCLTYP=""
+2 SET DA=BMCREF
SET DIE="^BMCREF("
SET DR="1404Select Type of Distribution"
DO ^DIE
KILL DA,DIE,DIU,DIVDR
+3 ;
+4 SET BMCLTYP=X
+5 IF BMCLTYP'="M"
GOTO ZIS
+6 ;
+7 ;Alt Resource Mail Certified Receipt Number
+8 SET DA=BMCREF
SET DIE="^BMCREF("
SET DR="1403Enter Certified Mail Receipt"
DO ^DIE
KILL DA,DIE,DIU,DIVDR
+9 ;
ZIS ;
+1 WRITE !!
SET XBRC="COMP^BMCFDRA"
SET XBRP="PRINT^BMCFDRA"
SET XBNS="BMC"
SET XBRX="XIT^BMCFDRA"
+2 DO ^XBDBQUE
+3 QUIT
+4 ;
PRINT ;EP
+1 IF $DATA(^BMCTFORM(BMCFTYPE,12))
XECUTE ^BMCTFORM(BMCFTYPE,12)
+2 QUIT
XIT ;
+1 ;BMC*4.0*4 IHS/OIT/FCJ ADDED BMCSIR
+2 KILL BMCCAP,BMCCHSR,BMCDA,BMCFILE,BMCFTYPE,BMCIOM,BMCKPDA,BMCNODE,BMCPG,BMCQUIT,BMCR0,BMCREF,BMCRNS,BMCV,BMCWP,BMCX,BMCY,BMCI,BMCDFN,BMCCHSAS
+3 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
+4 KILL BMCPROUT,BMCN,BMCNUM,BMCAGE,BMCFIRST,BMCLAST,BMCLTYP,BMCSIR
+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 IF BMCFTYPE'=1
QUIT
+2 ;Quit - No longer ask for CHS Preliminary Review per Stan 8/28/96
QUIT
+3 IF $PIECE(^BMCREF(BMCREF,0),U,4)'="C"
QUIT
+4 IF $PIECE($GET(^BMCREF(BMCREF,11)),U,20)]""
SET BMCCHSR=$PIECE(^BMCREF(BMCREF,11),U,20)
QUIT
+5 WRITE !!,$CHAR(7),$CHAR(7),"The CHS Preliminary Review has not been entered. Please enter it now.",!
+6 SET DIE="^BMCREF("
SET DA=BMCREF
SET DR=1120
DO ^DIE
KILL DIE,DA
+7 SET BMCCHSR=$PIECE($GET(^BMCREF(BMCREF,11)),U,20)
IF BMCCHSR=""
SET BMCCHSR="3"
WRITE !!,"No entry made. Defaulting to 'TO BE DETERMINED'.",!!
+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
