BMCFDR2 ; IHS/ITSC/FCJ - DRIVER TO PRINT SECONDARY REFERRAL LETTER ; [ 09/26/2006 4:01 PM ]
;;4.0;REFERRED CARE INFO SYSTEM;**2,3**;JAN 09, 2006;Build 101
;IHS/OIT/FCJ ADD LINE TO TEST FOR CLOSING SLAVE DEVICE
;ALSO ADDED CHECK FOR CHS STATUS AND UPDATE OPTION
;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
;
;This is the Main Driver Routine -
;RCIS REPORT OUTPUT DEFINITION - SECONDARY PROVIDER LETTER
;Calls PRINT ROUTINE BMCFPRN2
;Rewrote from original version no longer requires data entry
;4.0 All call now to BMCREF instead of BMCPROV, ask for prining of
; Prim ref HX and findings
; Added option to update CHS status
;
START ;
S BMCCPRV="",BMCAPDT="",BMCAPUR="",BMCDDT="",BMCDPUR=""
W:$D(IOF) @IOF
W "********** REFERRAL FORM PRINT-SECONDARY PROVIDER **********",!!
W "This report will produce a hard copy computer generated",!,"Secondary Provider Letter",!
S BMCQUIT=0
S BMCCPRV="" ;Secondary Provider Name
S BMCCPRVS="" ;Secondary Provider Specific
S BMCAPPDT="" ;Secondary Provider Appointment Date
S BMCAPUR="" ;Secondary Provider Purpose of Appointment
GETREF ;get referral entry
S BMCKIND=0 ; Determines If Type = IHS
S DIR(0)="S^1:STANDARD;2:AHCCCS",DIR("A")="Enter Secondary Letter Type",DIR("B")="STANDARD",DIR("?")="Enter Letter Form Output Choice" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G XIT
S BMCHOICE=Y
S BMCFTYPE=$S(BMCHOICE=1:4,BMCHOICE=2:6,1:4)
W ! S DIR(0)="Y",DIR("A")="Do you want to include Primary referral History and Findings",DIR("B")="Y" D ^DIR K DIR Q:$D(DUOUT)
S BMCPHX=+Y
W !! S BMCREF=""
S DIC="^BMCREF(",DIC(0)="AEMQ",DIC("A")="Select REFERRAL by Patient or by Referral Date or #: "
S DIC("S")="I $$FILTER^BMCFLTR(0,0,1)"
D DIC^BMCFMC
G:Y=-1 XIT
S (BMCREF,BMCDTIEN,BMCSRIEN)=+Y
I $D(^BMCTFORM(BMCFTYPE,11)) X ^BMCTFORM(BMCFTYPE,11) G:BMCQUIT GETREF
CHS I $P($G(^BMCREF(BMCSRIEN,0)),U,4)="C" D
.;BMC*4.0 4.19.07 IHS/OIT/FCJ BMCCHSA IS A PARM VAR CHG NXT 3 LNS TO BMCCHSAS
.S BMCCHSAS=$P($G(^BMCREF(BMCSRIEN,11)),U,12)
.S BMCCHSAP=$$EXTSET^XBFUNC(90001,1112,BMCCHSAS)
.I BMCCHSAS="" S BMCCHSAP="UNKNOWN"
.W !!,?10,"**CHS APPROVAL STATUS**: ",BMCCHSAP,!!
.;Ask if Edit CHS Approval Status
.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
.Q:$D(DIRUT)
.Q:Y=0
.D CHSSTAT^BMCFDRC
G:$D(DIRUT) XIT
S (BMCRIEN,BMCREF)=$P(^BMCREF(BMCSRIEN,1),U,2)
;
IHS ;IHS Type - Get IHS Facility
I $P($G(^BMCREF(BMCSRIEN,0)),U,4)="I" D
.S BMCCPRV=$P($G(^BMCREF(BMCSRIEN,0)),U,8) D
.S BMCCPRVP=$P($G(^DIC(4,BMCCPRV,0)),U)
.S BMCKIND=1
;
;
GETPROV ;CHS Secondary Provider/Vendor
S BMCCPRV=$P($G(^BMCREF(BMCSRIEN,0)),U,7)
S:BMCCPRV BMCCPRVP=$P($G(^AUTTVNDR(BMCCPRV,0)),U)
I $P(^BMCREF(BMCSRIEN,0),U,9) S BMCCPRVS=$$VAL^XBDIQ1(90001.53,$P(^BMCREF(BMCSRIEN,0),U,9),.01)
;
APPTDT ;Appointment Date
S BMCAPPDT=$P(^BMCREF(BMCSRIEN,11),U,6)
;
PUR ;Purpose of Appointment
S BMCAPUR=$P(^BMCREF(BMCSRIEN,12),U)
;
ASKCON ;ASK TO PRINT CONSULT LETTER ;BMC*4.0*2 IHS/OIT/FCJ
D ASKCON^BMCFDR
ZIS ;
W !! S XBRC="COMP^BMCFDR2",XBRP="PRINT^BMCFDR2",XBNS="BMC",XBRX="XIT^BMCFDR2"
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
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,BMCDTIEN,BMCCPRV,BMCAPPDT,BMCAPUR,BMCDTIEN,BMCCHSAP,BMCCHSAS
K BMCAPDT,BMCHOICE,BMCKIND,BMCTYPE,BMCDDT,BMCDPUR,BMCCMT,BMCCPRVP,BMCCPRVS,BMCDT,BMCRIEN,BMCSRIEN,BMCR1,BMCPHX
I $D(IO("S")) S IOP="`"_IOS D ^%ZIS
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
BMCFDR2 ; IHS/ITSC/FCJ - DRIVER TO PRINT SECONDARY REFERRAL LETTER ; [ 09/26/2006 4:01 PM ]
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**2,3**;JAN 09, 2006;Build 101
+2 ;IHS/OIT/FCJ ADD LINE TO TEST FOR CLOSING SLAVE DEVICE
+3 ;ALSO ADDED CHECK FOR CHS STATUS AND UPDATE OPTION
+4 ;4.0*2 9-21-06 IHS/OIT/FCJ ASK TO PRNT CONSULT LETTER
+5 ;4.0*3 4.19.07 IHS/OIT/FCJ BMCCHSA IS A PARM VAR CHG TO BMCCHSAS
+6 ;
+7 ;This is the Main Driver Routine -
+8 ;RCIS REPORT OUTPUT DEFINITION - SECONDARY PROVIDER LETTER
+9 ;Calls PRINT ROUTINE BMCFPRN2
+10 ;Rewrote from original version no longer requires data entry
+11 ;4.0 All call now to BMCREF instead of BMCPROV, ask for prining of
+12 ; Prim ref HX and findings
+13 ; Added option to update CHS status
+14 ;
START ;
+1 SET BMCCPRV=""
SET BMCAPDT=""
SET BMCAPUR=""
SET BMCDDT=""
SET BMCDPUR=""
+2 IF $DATA(IOF)
WRITE @IOF
+3 WRITE "********** REFERRAL FORM PRINT-SECONDARY PROVIDER **********",!!
+4 WRITE "This report will produce a hard copy computer generated",!,"Secondary Provider Letter",!
+5 SET BMCQUIT=0
+6 ;Secondary Provider Name
SET BMCCPRV=""
+7 ;Secondary Provider Specific
SET BMCCPRVS=""
+8 ;Secondary Provider Appointment Date
SET BMCAPPDT=""
+9 ;Secondary Provider Purpose of Appointment
SET BMCAPUR=""
GETREF ;get referral entry
+1 ; Determines If Type = IHS
SET BMCKIND=0
+2 SET DIR(0)="S^1:STANDARD;2:AHCCCS"
SET DIR("A")="Enter Secondary Letter Type"
SET DIR("B")="STANDARD"
SET DIR("?")="Enter Letter Form Output Choice"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
GOTO XIT
+4 SET BMCHOICE=Y
+5 SET BMCFTYPE=$SELECT(BMCHOICE=1:4,BMCHOICE=2:6,1:4)
+6 WRITE !
SET DIR(0)="Y"
SET DIR("A")="Do you want to include Primary referral History and Findings"
SET DIR("B")="Y"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
QUIT
+7 SET BMCPHX=+Y
+8 WRITE !!
SET BMCREF=""
+9 SET DIC="^BMCREF("
SET DIC(0)="AEMQ"
SET DIC("A")="Select REFERRAL by Patient or by Referral Date or #: "
+10 SET DIC("S")="I $$FILTER^BMCFLTR(0,0,1)"
+11 DO DIC^BMCFMC
+12 IF Y=-1
GOTO XIT
+13 SET (BMCREF,BMCDTIEN,BMCSRIEN)=+Y
+14 IF $DATA(^BMCTFORM(BMCFTYPE,11))
XECUTE ^BMCTFORM(BMCFTYPE,11)
IF BMCQUIT
GOTO GETREF
CHS IF $PIECE($GET(^BMCREF(BMCSRIEN,0)),U,4)="C"
Begin DoDot:1
+1 ;BMC*4.0 4.19.07 IHS/OIT/FCJ BMCCHSA IS A PARM VAR CHG NXT 3 LNS TO BMCCHSAS
+2 SET BMCCHSAS=$PIECE($GET(^BMCREF(BMCSRIEN,11)),U,12)
+3 SET BMCCHSAP=$$EXTSET^XBFUNC(90001,1112,BMCCHSAS)
+4 IF BMCCHSAS=""
SET BMCCHSAP="UNKNOWN"
+5 WRITE !!,?10,"**CHS APPROVAL STATUS**: ",BMCCHSAP,!!
+6 ;Ask if Edit CHS Approval Status
+7 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
+8 IF $DATA(DIRUT)
QUIT
+9 IF Y=0
QUIT
+10 DO CHSSTAT^BMCFDRC
End DoDot:1
+11 IF $DATA(DIRUT)
GOTO XIT
+12 SET (BMCRIEN,BMCREF)=$PIECE(^BMCREF(BMCSRIEN,1),U,2)
+13 ;
IHS ;IHS Type - Get IHS Facility
+1 IF $PIECE($GET(^BMCREF(BMCSRIEN,0)),U,4)="I"
Begin DoDot:1
+2 SET BMCCPRV=$PIECE($GET(^BMCREF(BMCSRIEN,0)),U,8)
Begin DoDot:2
End DoDot:2
+3 SET BMCCPRVP=$PIECE($GET(^DIC(4,BMCCPRV,0)),U)
+4 SET BMCKIND=1
End DoDot:1
+5 ;
+6 ;
GETPROV ;CHS Secondary Provider/Vendor
+1 SET BMCCPRV=$PIECE($GET(^BMCREF(BMCSRIEN,0)),U,7)
+2 IF BMCCPRV
SET BMCCPRVP=$PIECE($GET(^AUTTVNDR(BMCCPRV,0)),U)
+3 IF $PIECE(^BMCREF(BMCSRIEN,0),U,9)
SET BMCCPRVS=$$VAL^XBDIQ1(90001.53,$PIECE(^BMCREF(BMCSRIEN,0),U,9),.01)
+4 ;
APPTDT ;Appointment Date
+1 SET BMCAPPDT=$PIECE(^BMCREF(BMCSRIEN,11),U,6)
+2 ;
PUR ;Purpose of Appointment
+1 SET BMCAPUR=$PIECE(^BMCREF(BMCSRIEN,12),U)
+2 ;
ASKCON ;ASK TO PRINT CONSULT LETTER ;BMC*4.0*2 IHS/OIT/FCJ
+1 DO ASKCON^BMCFDR
ZIS ;
+1 WRITE !!
SET XBRC="COMP^BMCFDR2"
SET XBRP="PRINT^BMCFDR2"
SET XBNS="BMC"
SET XBRX="XIT^BMCFDR2"
+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
+2 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
+3 KILL BMCPROUT,BMCN,BMCNUM,BMCAGE,BMCFIRST,BMCLAST,BMCLTYP,BMCDTIEN,BMCCPRV,BMCAPPDT,BMCAPUR,BMCDTIEN,BMCCHSAP,BMCCHSAS
+4 KILL BMCAPDT,BMCHOICE,BMCKIND,BMCTYPE,BMCDDT,BMCDPUR,BMCCMT,BMCCPRVP,BMCCPRVS,BMCDT,BMCRIEN,BMCSRIEN,BMCR1,BMCPHX
+5 IF $DATA(IO("S"))
SET IOP="`"_IOS
DO ^%ZIS
+6 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
