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
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,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
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
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'.",!!
;
Q
AHCCCS ;EP
W !!,$C(7),$C(7),"This letter must be printed on a printer capable of 132 character print.",!!
Q
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
