BMCRRSPP ; IHS/PHXAO/TMJ - SECONDARY PROVIDER LETTER ;
;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006
;
;IHS/ITSC/FCJ WAS NOT PRINTING COMMENTS ;WRONG FIELDS WERE PRINTING
; PRINT REF TYPE;REMOVED KILL AND RESET BMCOLOC; PRT SUFFIX
;
S BMCPG=0 D @("HEAD"_(2-($E(IOST,1,2)="C-"))) I '$D(^XTMP("BMCRRSP",BMCJOB,BMCBT)) W !,"No referrals to report",! G XIT
S BMCPN=0,BMCQUIT=0
S BMCDATE="" F S BMCDATE=$O(^XTMP("BMCRRSP",BMCJOB,BMCBT,"DATA HITS",BMCDATE)) Q:BMCDATE=""!(BMCQUIT) D P
XIT ;
K ^XTMP("BMCRRSP",BMCJOB,BMCBT)
D DONE^BMCRLP2
D KILL^AUPNPAT
K BMCI,BMCDATE,BMCOMDT,BMCRDT,BMCREVN,BMCREVP
S BMCOLOC=$P(^BMCPARM(DUZ(2),0),U,11)
Q
P ;
S BMCPN="" F S BMCPN=$O(^XTMP("BMCRRSP",BMCJOB,BMCBT,"DATA HITS",BMCDATE,BMCPN)) Q:BMCPN=""!(BMCQUIT) D PRINT
Q
PRINT ;print one referral
I $Y>(IOSL-10) D HEAD Q:BMCQUIT
S BMCRDT=0
F S BMCRDT=$O(^XTMP("BMCRRSP",BMCJOB,BMCBT,"DATA HITS",BMCDATE,BMCPN,BMCRDT)) Q:BMCRDT'=+BMCRDT!(BMCQUIT) D D PRINT1
.S BMCRREC=^BMCREF(BMCRDT,0),DFN=$P(BMCRREC,U,3)
.S BMCREF=$P(^BMCREF(BMCRDT,1),U,2)
.S BMCSUF=$P($G(^BMCREF(BMCRDT,1)),U)
Q
PRINT1 ;
I $Y>(IOSL-3) D HEAD Q:BMCQUIT
S BMCHRN="????" I $D(^AUPNPAT(DFN,41,DUZ(2)))
S BMCHRN=$P(^AUTTLOC(DUZ(2),0),U,7)_$P(^AUPNPAT(DFN,41,DUZ(2),0),U,2)
W !,$E($P(^DPT(DFN,0),U),1,30),?32,BMCHRN,?43,"DOB: ",$$DOB^AUPNPAT(DFN,"E")," ",$$AGE^AUPNPAT(DFN,DT,"R")," ",$$SSN^AUPNPAT(DFN)
W !,"Referral #: ",$P($G(^BMCREF(BMCRDT,0)),U,2)," ",BMCSUF
W ?29,"Date Init: ",$$REFDTI^BMCRLU(BMCRDT,"S")
W ?50,"Tribe: ",$E($$TRIBE^AUPNPAT(DFN,"E"),1,20)
;
;
LETTER ;Print Letter Information
;
W !,"Refferal Type: "_$$VAL^XBDIQ1(90001,BMCREF,.04)
S Y=$P(BMCRREC,U,1) D DD^%DT S BMCCOMDT=Y
W !,"LETTER DATE: "_BMCCOMDT
S BMCREVP=$P(BMCRREC,U,25) S BMCREVN=$P(^VA(200,BMCREVP,0),U,1)
W ?43,"USER CREATED: "_BMCREVN,!
S BMCAPPT=$P(^BMCREF(BMCRDT,11),U,5) ;Exp Appt Date
S BMCPUR=$P($G(^BMCREF(BMCRDT,12)),U) ; Purpose
S BMCIHSP=$P(BMCRREC,U,8) ;IHS Provider
S BMCSPRV=$P(BMCRREC,U,7) ;Provider/Vendor IEN
S:BMCSPRV'="" BMCSPRV=$P(^AUTTVNDR(BMCSPRV,0),U)
S Y=BMCAPPT D DD^%DT S BMCAPPT=Y
W !,"Expected Appoinment Date: ",BMCAPPT
W !,"Purpose of Appointment: ",BMCPUR
W !,"Contract Vendor: ",BMCSPRV
S:BMCIHSP'="" BMCIHSP=$P(^DIC(4,BMCIHSP,0),U)
W !,"IHS Facility: ",BMCIHSP
;
LOCAT ;Print Local Categories
I $D(^BMCREF(BMCREF,21,0)) D
. S BMCLOCC=0
.F S BMCLOCC=$O(^BMCREF(BMCREF,21,"B",BMCLOCC)) Q:BMCLOCC'=+BMCLOCC D
..S BMCLOCI=0
..F S BMCLOCI=$O(^BMCREF(BMCREF,21,"B",BMCLOCC,BMCLOCI)) Q:BMCLOCI'=+BMCLOCI D
... S BMCLOCP=$P(^BMCREF(BMCREF,21,BMCLOCI,0),U)
... Q:BMCLOCP=""
... S BMCLOCPP=$P(^BMCLCAT(BMCLOCP,0),U)
... W !,"Local Category: "_BMCLOCPP
;
;
ALT ;Alternate Resource Letter Date
I $Y>(IOSL-3) D HEAD Q:BMCQUIT
W !,"Alternate Resource Letter Date: ",$$VAL^XBDIQ1(90001,BMCREF,1401)
;
BO ;Business office comments
S BMCI=0,Y=0
F S BMCI=$O(^BMCCOM("AD",BMCREF,BMCI)) Q:BMCI'?1N.N D Q:BMCQUIT
.Q:$P(^BMCCOM(BMCI,0),U,5)'="B"
.I Y=0 W !,"Business Office Comments:"
.S BMCNODE=1,BMCIOM=70,BMCFILE=90001.03,BMCDA=BMCI D WP^BMCFDR K BMCIOM
.S Y=0 F S Y=$O(BMCWP(Y)) Q:Y'=+Y!(BMCQUIT) D
..I $Y>(IOSL-3) D HEAD Q:BMCQUIT
..W !?5,BMCWP(Y)
Q:BMCQUIT
NEXT ;
W !,"--------------------",!
Q
HEAD ;ENTRY POINT
NEW X,Y,Z,C
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BMCQUIT=1 Q
HEAD1 ;
W:$D(IOF) @IOF
HEAD2 ;
S BMCPG=BMCPG+1
W !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
W !?(80-$L($P(^DIC(4,DUZ(2),0),U))/2),$P(^DIC(4,DUZ(2),0),U),?72,"Page ",BMCPG,!
S Y=DT D DD^%DT W ?(80-$L(Y)/2),Y,!
W ?21,"**SECONDARY PROVIDER LETTER BY DATE**",!
S Y=BMCBD D DD^%DT W ?17,"BEG DATE: "_Y
S Y=BMCED D DD^%DT W ?40,"END DATE: "_Y,!
W !,$TR($J(" ",80)," ","-")
Q
BMCRRSPP ; IHS/PHXAO/TMJ - SECONDARY PROVIDER LETTER ;
+1 ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006
+2 ;
+3 ;IHS/ITSC/FCJ WAS NOT PRINTING COMMENTS ;WRONG FIELDS WERE PRINTING
+4 ; PRINT REF TYPE;REMOVED KILL AND RESET BMCOLOC; PRT SUFFIX
+5 ;
+6 SET BMCPG=0
DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))
IF '$DATA(^XTMP("BMCRRSP",BMCJOB,BMCBT))
WRITE !,"No referrals to report",!
GOTO XIT
+7 SET BMCPN=0
SET BMCQUIT=0
+8 SET BMCDATE=""
FOR
SET BMCDATE=$ORDER(^XTMP("BMCRRSP",BMCJOB,BMCBT,"DATA HITS",BMCDATE))
IF BMCDATE=""!(BMCQUIT)
QUIT
DO P
XIT ;
+1 KILL ^XTMP("BMCRRSP",BMCJOB,BMCBT)
+2 DO DONE^BMCRLP2
+3 DO KILL^AUPNPAT
+4 KILL BMCI,BMCDATE,BMCOMDT,BMCRDT,BMCREVN,BMCREVP
+5 SET BMCOLOC=$PIECE(^BMCPARM(DUZ(2),0),U,11)
+6 QUIT
P ;
+1 SET BMCPN=""
FOR
SET BMCPN=$ORDER(^XTMP("BMCRRSP",BMCJOB,BMCBT,"DATA HITS",BMCDATE,BMCPN))
IF BMCPN=""!(BMCQUIT)
QUIT
DO PRINT
+2 QUIT
PRINT ;print one referral
+1 IF $Y>(IOSL-10)
DO HEAD
IF BMCQUIT
QUIT
+2 SET BMCRDT=0
+3 FOR
SET BMCRDT=$ORDER(^XTMP("BMCRRSP",BMCJOB,BMCBT,"DATA HITS",BMCDATE,BMCPN,BMCRDT))
IF BMCRDT'=+BMCRDT!(BMCQUIT)
QUIT
Begin DoDot:1
+4 SET BMCRREC=^BMCREF(BMCRDT,0)
SET DFN=$PIECE(BMCRREC,U,3)
+5 SET BMCREF=$PIECE(^BMCREF(BMCRDT,1),U,2)
+6 SET BMCSUF=$PIECE($GET(^BMCREF(BMCRDT,1)),U)
End DoDot:1
DO PRINT1
+7 QUIT
PRINT1 ;
+1 IF $Y>(IOSL-3)
DO HEAD
IF BMCQUIT
QUIT
+2 SET BMCHRN="????"
IF $DATA(^AUPNPAT(DFN,41,DUZ(2)))
+3 SET BMCHRN=$PIECE(^AUTTLOC(DUZ(2),0),U,7)_$PIECE(^AUPNPAT(DFN,41,DUZ(2),0),U,2)
+4 WRITE !,$EXTRACT($PIECE(^DPT(DFN,0),U),1,30),?32,BMCHRN,?43,"DOB: ",$$DOB^AUPNPAT(DFN,"E")," ",$$AGE^AUPNPAT(DFN,DT,"R")," ",$$SSN^AUPNPAT(DFN)
+5 WRITE !,"Referral #: ",$PIECE($GET(^BMCREF(BMCRDT,0)),U,2)," ",BMCSUF
+6 WRITE ?29,"Date Init: ",$$REFDTI^BMCRLU(BMCRDT,"S")
+7 WRITE ?50,"Tribe: ",$EXTRACT($$TRIBE^AUPNPAT(DFN,"E"),1,20)
+8 ;
+9 ;
LETTER ;Print Letter Information
+1 ;
+2 WRITE !,"Refferal Type: "_$$VAL^XBDIQ1(90001,BMCREF,.04)
+3 SET Y=$PIECE(BMCRREC,U,1)
DO DD^%DT
SET BMCCOMDT=Y
+4 WRITE !,"LETTER DATE: "_BMCCOMDT
+5 SET BMCREVP=$PIECE(BMCRREC,U,25)
SET BMCREVN=$PIECE(^VA(200,BMCREVP,0),U,1)
+6 WRITE ?43,"USER CREATED: "_BMCREVN,!
+7 ;Exp Appt Date
SET BMCAPPT=$PIECE(^BMCREF(BMCRDT,11),U,5)
+8 ; Purpose
SET BMCPUR=$PIECE($GET(^BMCREF(BMCRDT,12)),U)
+9 ;IHS Provider
SET BMCIHSP=$PIECE(BMCRREC,U,8)
+10 ;Provider/Vendor IEN
SET BMCSPRV=$PIECE(BMCRREC,U,7)
+11 IF BMCSPRV'=""
SET BMCSPRV=$PIECE(^AUTTVNDR(BMCSPRV,0),U)
+12 SET Y=BMCAPPT
DO DD^%DT
SET BMCAPPT=Y
+13 WRITE !,"Expected Appoinment Date: ",BMCAPPT
+14 WRITE !,"Purpose of Appointment: ",BMCPUR
+15 WRITE !,"Contract Vendor: ",BMCSPRV
+16 IF BMCIHSP'=""
SET BMCIHSP=$PIECE(^DIC(4,BMCIHSP,0),U)
+17 WRITE !,"IHS Facility: ",BMCIHSP
+18 ;
LOCAT ;Print Local Categories
+1 IF $DATA(^BMCREF(BMCREF,21,0))
Begin DoDot:1
+2 SET BMCLOCC=0
+3 FOR
SET BMCLOCC=$ORDER(^BMCREF(BMCREF,21,"B",BMCLOCC))
IF BMCLOCC'=+BMCLOCC
QUIT
Begin DoDot:2
+4 SET BMCLOCI=0
+5 FOR
SET BMCLOCI=$ORDER(^BMCREF(BMCREF,21,"B",BMCLOCC,BMCLOCI))
IF BMCLOCI'=+BMCLOCI
QUIT
Begin DoDot:3
+6 SET BMCLOCP=$PIECE(^BMCREF(BMCREF,21,BMCLOCI,0),U)
+7 IF BMCLOCP=""
QUIT
+8 SET BMCLOCPP=$PIECE(^BMCLCAT(BMCLOCP,0),U)
+9 WRITE !,"Local Category: "_BMCLOCPP
End DoDot:3
End DoDot:2
End DoDot:1
+10 ;
+11 ;
ALT ;Alternate Resource Letter Date
+1 IF $Y>(IOSL-3)
DO HEAD
IF BMCQUIT
QUIT
+2 WRITE !,"Alternate Resource Letter Date: ",$$VAL^XBDIQ1(90001,BMCREF,1401)
+3 ;
BO ;Business office comments
+1 SET BMCI=0
SET Y=0
+2 FOR
SET BMCI=$ORDER(^BMCCOM("AD",BMCREF,BMCI))
IF BMCI'?1N.N
QUIT
Begin DoDot:1
+3 IF $PIECE(^BMCCOM(BMCI,0),U,5)'="B"
QUIT
+4 IF Y=0
WRITE !,"Business Office Comments:"
+5 SET BMCNODE=1
SET BMCIOM=70
SET BMCFILE=90001.03
SET BMCDA=BMCI
DO WP^BMCFDR
KILL BMCIOM
+6 SET Y=0
FOR
SET Y=$ORDER(BMCWP(Y))
IF Y'=+Y!(BMCQUIT)
QUIT
Begin DoDot:2
+7 IF $Y>(IOSL-3)
DO HEAD
IF BMCQUIT
QUIT
+8 WRITE !?5,BMCWP(Y)
End DoDot:2
End DoDot:1
IF BMCQUIT
QUIT
+9 IF BMCQUIT
QUIT
NEXT ;
+1 WRITE !,"--------------------",!
+2 QUIT
HEAD ;ENTRY POINT
+1 NEW X,Y,Z,C
+2 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET BMCQUIT=1
QUIT
HEAD1 ;
+1 IF $DATA(IOF)
WRITE @IOF
HEAD2 ;
+1 SET BMCPG=BMCPG+1
+2 WRITE !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
+3 WRITE !?(80-$LENGTH($PIECE(^DIC(4,DUZ(2),0),U))/2),$PIECE(^DIC(4,DUZ(2),0),U),?72,"Page ",BMCPG,!
+4 SET Y=DT
DO DD^%DT
WRITE ?(80-$LENGTH(Y)/2),Y,!
+5 WRITE ?21,"**SECONDARY PROVIDER LETTER BY DATE**",!
+6 SET Y=BMCBD
DO DD^%DT
WRITE ?17,"BEG DATE: "_Y
+7 SET Y=BMCED
DO DD^%DT
WRITE ?40,"END DATE: "_Y,!
+8 WRITE !,$TRANSLATE($JUSTIFY(" ",80)," ","-")
+9 QUIT
