- BMCRR7P2 ; IHS/PHXAO/TMJ - DETAILED OLOG REPORT ;
- ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006
- S BMC80E="==============================================================================="
- S BMC80D="-------------------------------------------------------------------------------"
- S BMCPG=0 I '$D(^XTMP("BMCRR7",BMCJOB,BMCBT)) D @("HEAD"_(2-($E(IOST,1,2)="C-"))) W !,"No referrals to report",! G XIT
- S BMCPN=0 K BMCQUIT D @("HEAD"_(2-($E(IOST,1,2)="C-")))
- F S BMCPN=$O(^XTMP("BMCRR7",BMCJOB,BMCBT,"DATA HITS",BMCPN)) Q:BMCPN=""!($D(BMCQUIT)) D DFN
- XIT ;
- K ^XTMP("BMCRR7",BMCJOB,BMCBT)
- K BMCRREC,BMCREF,BMC2,BMCI,BMCG,BMCX,BMCSTR,BMCCTR,BMCFILE,BMCNODE,BMCAR,BMC1,BMCBT,BMCH,BMCPG,BMCV,BMCVDFN,BMCVDG,BMCVFLE,BMCVI,BMCVIGR,BMCVL,BMCVNM,BMCX,BMCY
- D KILL^AUPNPAT
- K DFN
- Q
- DFN ;
- S DFN="" F S DFN=$O(^XTMP("BMCRR7",BMCJOB,BMCBT,"DATA HITS",BMCPN,DFN)) Q:DFN=""!($D(BMCQUIT)) D PRINT
- Q
- PRINT ;print one referral
- S BMC2="15,61",BMC1="1,45"
- S BMCREF=0 F S BMCREF=$O(^XTMP("BMCRR7",BMCJOB,BMCBT,"DATA HITS",BMCPN,DFN,BMCREF)) Q:BMCREF'=+BMCREF!($D(BMCQUIT)) S BMCRREC=^BMCREF(BMCREF,0) D BUILD
- Q
- BUILD ; build array
- K BMCAR
- ;D TERM^VALM0
- S BMCRREC=^BMCREF(BMCREF,0)
- ;I BMCOPT'="B" D HEAD Q:$D(BMCQUIT)
- W !!
- S Y=$P(BMCRREC,U,3) D ^AUPNPAT
- S BMCSTR="",BMCCTR=0
- S BMCSTR="Name: "_$E($P(^DPT($P(BMCRREC,U,3),0),U),1,25)_" "_" "_$$FMTE^XLFDT(AUPNDOB,"5D")_" "_$$VAL^XBDIQ1(9000001,DFN,1102.98)_" "_$$SSN^AUPNPAT(DFN) D SET Q:$D(BMCQUIT)
- S X=$$VAL^XBDIQ1(90001,BMCREF,.02) W ?57,"Ref #: "_X
- K BMCAR D ENPM^XBDIQ1(2.01,DFN_",0",".01","BMCAR(")
- S I=0 F S I=$O(BMCAR(I)) Q:I'=+I S BMCSTR=BMCAR(I,.01)_" "
- I BMCSTR]"" S BMCSTR="AKA'S: "_BMCSTR D SET Q:$D(BMCQUIT)
- S BMCSTR="Tribe: "_$E($$VAL^XBDIQ1(9000001,DFN,1108),1,20)_" Tribal #: "_$S($$VAL^XBDIQ1(9000001,DFN,.07)]"":$$VAL^XBDIQ1(9000001,DFN,.07),1:"< ? >")
- S BMCSTR=BMCSTR_" "_$$VAL^XBDIQ1(9000001,DFN,1118) D SET Q:$D(BMCQUIT)
- CHARTS ;print duz(2) chart then first 4 in mult.
- K BMCAR D ENPM^XBDIQ1(9000001.41,DFN_",0",".02","BMCAR(")
- I $D(BMCAR(DUZ(2))) S BMCSTR=$P(^AUTTLOC(DUZ(2),0),U,7)_"#: "_BMCAR(DUZ(2),.02) S (I,F,C)=0 F S I=$O(BMCAR(I)) Q:I'=+I!(C>4) I I'=DUZ(2) S C=C+1,BMCSTR=BMCSTR_" "_$P(^AUTTLOC(I,0),U,7)_"#: "_BMCAR(I,.02)
- D SET Q:$D(BMCQUIT)
- REQ ;
- S BMCSTR="Referred To:",Y=$$FACREF^BMCRLU(BMCREF),BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,15,$L(Y)),Y="Attending:"
- S BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,45,$L(Y)),Y=$E($$VAL^XBDIQ1(90001,BMCREF,.09),1,18),BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,56,$L(Y)) D SET Q:$D(BMCQUIT)
- S BMCSTR="Referred By: "_$$VAL^XBDIQ1(90001,BMCREF,.06) D SET Q:$D(BMCQUIT)
- ;K BMCAR D ENP^XBDIQ1(90001,BMCREF,".19;.31","BMCAR(","E") D S
- S BMCSTR="Beg DOS: "_$$AVDOS^BMCRLU(BMCREF)_" Est LOS: "_$$AVLOS^BMCRLU(BMCREF)_" LOS to Date: "_$$VAL^XBDIQ1(90001,BMCREF,.1499) D SET Q:$D(BMCQUIT)
- ;S BMCSTR="Est LOS:",Y=$$AVLOS^BMCRLU(BMCREF),BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,15,$L(Y)),Y="LOS to Date: ",BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,45,$L(Y)),Y=$$VAL^XBDIQ1(90001,BMCREF,.1499),BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,61,$L(Y)) D SET Q:$D(BMCQUIT)
- S BMCSTR="Purpose: "_$$VAL^XBDIQ1(90001,BMCREF,1201) D SET Q:$D(BMCQUIT)
- DRG ;
- S BMCSTR="Primary Payor: "_$$VAL^XBDIQ1(90001,BMCREF,.11) D SET Q:$D(BMCQUIT)
- D VFILES
- 2 ;
- G:'$D(^BMCREF(BMCREF,2)) 3
- S BMCSTR="Business Office Notes: " D SET Q:$D(BMCQUIT)
- K BMCG S BMCFILE=90001,BMCREF=BMCREF,BMCNODE=2 D WP
- S BMCSTR="" D SET Q:$D(BMCQUIT)
- 3 ;
- G:'$D(^BMCREF(BMCREF,3)) COMMENTS
- S BMCSTR="Discharge Comments:" D SET Q:$D(BMCQUIT)
- K BMCG S BMCFILE=90001,BMCREF=BMCREF,BMCNODE=3 D WP
- S BMCSTR="" D SET Q:$D(BMCQUIT)
- I '$D(^BMCCOM("AD",BMCREF)) Q
- S BMCI=0 F S BMCI=$O(^BMCCOM("AD",BMCREF,BMCI)) Q:BMCI'=+BMCI!($D(BMCQUIT)) D
- .S Y=$P(^BMCCOM(BMCI,0),U),BMCSTR="Comments Made on "_$$FMTE^XLFDT(Y,"5D") D SET Q:$D(BMCQUIT)
- .S BMCG="^BMCCOM("_BMCI_",1,BMCX)" D WP
- Q:BMCOPT="B"
- S BMCSTR="" D SET S BMCSTR="Additional Comments:" D SET
- Q
- VFILES ;set up array of all v file entries
- NEW DA,D0,DIC,DIQ,DR,DI
- S BMCVFLE=90001 F BMCVL=0:0 S BMCVFLE=$O(^DIC(BMCVFLE)) Q:BMCVFLE>90001.02!(BMCVFLE'=+BMCVFLE)!($D(BMCQUIT)) D VF2
- Q
- ;
- VF2 ;
- S BMCVNM=$P(^DIC(BMCVFLE,0),U),BMCVDG=^DIC(BMCVFLE,0,"GL"),BMCVIGR=BMCVDG_"""AD"",BMCREF,BMCVDFN)",BMCVDFN=""
- F BMCVI=1:1 S BMCVDFN=$O(@BMCVIGR) Q:BMCVDFN="" D VF3
- Q
- ;
- VF3 ;
- I BMCVI<2 S BMCSTR=$E(BMCVNM)_$$LOW^XLFSTR($E(BMCVNM,2,99)) D SET Q:$D(BMCQUIT)
- K BMCAR D ENP^XBDIQ1(BMCVFLE,BMCVDFN,".01;.06","BMCAR(","E")
- S Y=BMCAR(.01)_" - "_BMCAR(.06),BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,3,$L(Y)) D SET Q:$D(BMCQUIT)
- Q
- S ;
- S (C,F)=0 F S F=$O(BMCAR(F)) Q:F'=+F I BMCAR(F)]"" D
- .S C=C+1,Y=$E($S($G(^DD(90001,F,.1))]"":$P(^DD(90001,F,.1),U),1:$P(^DD(90001,F,0),U)),1,13)_": ",Y=$E(Y)_$$LOW^XLFSTR($E(Y,2,999)),BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,$P(BMC1,",",C),$L(Y))
- .S Y=$E(BMCAR(F),1,20),BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,$P(BMC2,",",C),$L(Y))
- D SET Q:$D(BMCQUIT)
- Q
- BUILD1 ;
- S BMCSTR=$E(BMCH,1,25)_":",BMCSTR=$$SETSTR^VALM1(BMCV,BMCSTR,28,$L(BMCV))
- D SET Q:$D(BMCQUIT)
- Q
- SET ;set array
- I $Y>(IOSL-3),BMCOPT'="B" D HEAD Q:$D(BMCQUIT)
- W !,BMCSTR
- S BMCSTR=""
- Q
- ;
- WP ;EP - Entry point to print wp fields pass node in BMCNODE
- ;PASS FILE IN BMCFILE, ENTRY IN BMCREF
- K ^UTILITY($J,"W")
- S BMCX=0
- I '$D(BMCG) S BMCG=^DIC(BMCFILE,0,"GL"),BMCG=BMCG_BMCREF_","_BMCNODE_",BMCX)"
- S DIWL=1,DIWR=75,DIWF="C75" F S BMCX=$O(@BMCG) Q:BMCX'=+BMCX!($D(BMCQUIT)) D
- .S Y=$P(BMCG,")")_",0)" S X=@Y D ^DIWP
- .Q
- WPS ;EP
- S Z=0 F S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z!($D(BMCQUIT)) S BMCSTR=$$SETSTR^VALM1(^UTILITY($J,"W",DIWL,Z,0),BMCSTR,5,$L(^UTILITY($J,"W",DIWL,Z,0))) D SET Q:$D(BMCQUIT)
- K DIWL,DIWR,DIWF,Z
- K ^UTILITY($J,"W"),BMCNODE,BMCFILE,BMCG,BMCCOL
- Q
- HEAD ;
- 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 !,"***** CONFIDENTIAL PATIENT INFORMATION ***** Referral Summary (TLOG) Page ",BMCPG
- W !,"Report Run Date: ",$$FMTE^XLFDT($$HTFM^XLFDT($H),"1P")
- W !,BMC80D
- Q
- BMCRR7P2 ; IHS/PHXAO/TMJ - DETAILED OLOG REPORT ;
- +1 ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006
- +2 SET BMC80E="==============================================================================="
- +3 SET BMC80D="-------------------------------------------------------------------------------"
- +4 SET BMCPG=0
- IF '$DATA(^XTMP("BMCRR7",BMCJOB,BMCBT))
- DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))
- WRITE !,"No referrals to report",!
- GOTO XIT
- +5 SET BMCPN=0
- KILL BMCQUIT
- DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))
- +6 FOR
- SET BMCPN=$ORDER(^XTMP("BMCRR7",BMCJOB,BMCBT,"DATA HITS",BMCPN))
- IF BMCPN=""!($DATA(BMCQUIT))
- QUIT
- DO DFN
- XIT ;
- +1 KILL ^XTMP("BMCRR7",BMCJOB,BMCBT)
- +2 KILL BMCRREC,BMCREF,BMC2,BMCI,BMCG,BMCX,BMCSTR,BMCCTR,BMCFILE,BMCNODE,BMCAR,BMC1,BMCBT,BMCH,BMCPG,BMCV,BMCVDFN,BMCVDG,BMCVFLE,BMCVI,BMCVIGR,BMCVL,BMCVNM,BMCX,BMCY
- +3 DO KILL^AUPNPAT
- +4 KILL DFN
- +5 QUIT
- DFN ;
- +1 SET DFN=""
- FOR
- SET DFN=$ORDER(^XTMP("BMCRR7",BMCJOB,BMCBT,"DATA HITS",BMCPN,DFN))
- IF DFN=""!($DATA(BMCQUIT))
- QUIT
- DO PRINT
- +2 QUIT
- PRINT ;print one referral
- +1 SET BMC2="15,61"
- SET BMC1="1,45"
- +2 SET BMCREF=0
- FOR
- SET BMCREF=$ORDER(^XTMP("BMCRR7",BMCJOB,BMCBT,"DATA HITS",BMCPN,DFN,BMCREF))
- IF BMCREF'=+BMCREF!($DATA(BMCQUIT))
- QUIT
- SET BMCRREC=^BMCREF(BMCREF,0)
- DO BUILD
- +3 QUIT
- BUILD ; build array
- +1 KILL BMCAR
- +2 ;D TERM^VALM0
- +3 SET BMCRREC=^BMCREF(BMCREF,0)
- +4 ;I BMCOPT'="B" D HEAD Q:$D(BMCQUIT)
- +5 WRITE !!
- +6 SET Y=$PIECE(BMCRREC,U,3)
- DO ^AUPNPAT
- +7 SET BMCSTR=""
- SET BMCCTR=0
- +8 SET BMCSTR="Name: "_$EXTRACT($PIECE(^DPT($PIECE(BMCRREC,U,3),0),U),1,25)_" "_" "_$$FMTE^XLFDT(AUPNDOB,"5D")_" "_$$VAL^XBDIQ1(9000001,DFN,1102.98)_" "_$$SSN^AUPNPAT(DFN)
- DO SET
- IF $DATA(BMCQUIT)
- QUIT
- +9 SET X=$$VAL^XBDIQ1(90001,BMCREF,.02)
- WRITE ?57,"Ref #: "_X
- +10 KILL BMCAR
- DO ENPM^XBDIQ1(2.01,DFN_",0",".01","BMCAR(")
- +11 SET I=0
- FOR
- SET I=$ORDER(BMCAR(I))
- IF I'=+I
- QUIT
- SET BMCSTR=BMCAR(I,.01)_" "
- +12 IF BMCSTR]""
- SET BMCSTR="AKA'S: "_BMCSTR
- DO SET
- IF $DATA(BMCQUIT)
- QUIT
- +13 SET BMCSTR="Tribe: "_$EXTRACT($$VAL^XBDIQ1(9000001,DFN,1108),1,20)_" Tribal #: "_$SELECT($$VAL^XBDIQ1(9000001,DFN,.07)]"":$$VAL^XBDIQ1(9000001,DFN,.07),1:"< ? >")
- +14 SET BMCSTR=BMCSTR_" "_$$VAL^XBDIQ1(9000001,DFN,1118)
- DO SET
- IF $DATA(BMCQUIT)
- QUIT
- CHARTS ;print duz(2) chart then first 4 in mult.
- +1 KILL BMCAR
- DO ENPM^XBDIQ1(9000001.41,DFN_",0",".02","BMCAR(")
- +2 IF $DATA(BMCAR(DUZ(2)))
- SET BMCSTR=$PIECE(^AUTTLOC(DUZ(2),0),U,7)_"#: "_BMCAR(DUZ(2),.02)
- SET (I,F,C)=0
- FOR
- SET I=$ORDER(BMCAR(I))
- IF I'=+I!(C>4)
- QUIT
- IF I'=DUZ(2)
- SET C=C+1
- SET BMCSTR=BMCSTR_" "_$PIECE(^AUTTLOC(I,0),U,7)_"#: "_BMCAR(I,.02)
- +3 DO SET
- IF $DATA(BMCQUIT)
- QUIT
- REQ ;
- +1 SET BMCSTR="Referred To:"
- SET Y=$$FACREF^BMCRLU(BMCREF)
- SET BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,15,$LENGTH(Y))
- SET Y="Attending:"
- +2 SET BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,45,$LENGTH(Y))
- SET Y=$EXTRACT($$VAL^XBDIQ1(90001,BMCREF,.09),1,18)
- SET BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,56,$LENGTH(Y))
- DO SET
- IF $DATA(BMCQUIT)
- QUIT
- +3 SET BMCSTR="Referred By: "_$$VAL^XBDIQ1(90001,BMCREF,.06)
- DO SET
- IF $DATA(BMCQUIT)
- QUIT
- +4 ;K BMCAR D ENP^XBDIQ1(90001,BMCREF,".19;.31","BMCAR(","E") D S
- +5 SET BMCSTR="Beg DOS: "_$$AVDOS^BMCRLU(BMCREF)_" Est LOS: "_$$AVLOS^BMCRLU(BMCREF)_" LOS to Date: "_$$VAL^XBDIQ1(90001,BMCREF,.1499)
- DO SET
- IF $DATA(BMCQUIT)
- QUIT
- +6 ;S BMCSTR="Est LOS:",Y=$$AVLOS^BMCRLU(BMCREF),BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,15,$L(Y)),Y="LOS to Date: ",BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,45,$L(Y)),Y=$$VAL^XBDIQ1(90001,BMCREF,.1499),BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,61,$L(Y)) D SET Q:$D(BMCQUIT)
- +7 SET BMCSTR="Purpose: "_$$VAL^XBDIQ1(90001,BMCREF,1201)
- DO SET
- IF $DATA(BMCQUIT)
- QUIT
- DRG ;
- +1 SET BMCSTR="Primary Payor: "_$$VAL^XBDIQ1(90001,BMCREF,.11)
- DO SET
- IF $DATA(BMCQUIT)
- QUIT
- +2 DO VFILES
- 2 ;
- +1 IF '$DATA(^BMCREF(BMCREF,2))
- GOTO 3
- +2 SET BMCSTR="Business Office Notes: "
- DO SET
- IF $DATA(BMCQUIT)
- QUIT
- +3 KILL BMCG
- SET BMCFILE=90001
- SET BMCREF=BMCREF
- SET BMCNODE=2
- DO WP
- +4 SET BMCSTR=""
- DO SET
- IF $DATA(BMCQUIT)
- QUIT
- 3 ;
- +1 IF '$DATA(^BMCREF(BMCREF,3))
- GOTO COMMENTS
- +2 SET BMCSTR="Discharge Comments:"
- DO SET
- IF $DATA(BMCQUIT)
- QUIT
- +3 KILL BMCG
- SET BMCFILE=90001
- SET BMCREF=BMCREF
- SET BMCNODE=3
- DO WP
- +4 SET BMCSTR=""
- DO SET
- IF $DATA(BMCQUIT)
- QUIT
- +1 IF '$DATA(^BMCCOM("AD",BMCREF))
- QUIT
- +2 SET BMCI=0
- FOR
- SET BMCI=$ORDER(^BMCCOM("AD",BMCREF,BMCI))
- IF BMCI'=+BMCI!($DATA(BMCQUIT))
- QUIT
- Begin DoDot:1
- +3 SET Y=$PIECE(^BMCCOM(BMCI,0),U)
- SET BMCSTR="Comments Made on "_$$FMTE^XLFDT(Y,"5D")
- DO SET
- IF $DATA(BMCQUIT)
- QUIT
- +4 SET BMCG="^BMCCOM("_BMCI_",1,BMCX)"
- DO WP
- End DoDot:1
- +5 IF BMCOPT="B"
- QUIT
- +6 SET BMCSTR=""
- DO SET
- SET BMCSTR="Additional Comments:"
- DO SET
- +7 QUIT
- VFILES ;set up array of all v file entries
- +1 NEW DA,D0,DIC,DIQ,DR,DI
- +2 SET BMCVFLE=90001
- FOR BMCVL=0:0
- SET BMCVFLE=$ORDER(^DIC(BMCVFLE))
- IF BMCVFLE>90001.02!(BMCVFLE'=+BMCVFLE)!($DATA(BMCQUIT))
- QUIT
- DO VF2
- +3 QUIT
- +4 ;
- VF2 ;
- +1 SET BMCVNM=$PIECE(^DIC(BMCVFLE,0),U)
- SET BMCVDG=^DIC(BMCVFLE,0,"GL")
- SET BMCVIGR=BMCVDG_"""AD"",BMCREF,BMCVDFN)"
- SET BMCVDFN=""
- +2 FOR BMCVI=1:1
- SET BMCVDFN=$ORDER(@BMCVIGR)
- IF BMCVDFN=""
- QUIT
- DO VF3
- +3 QUIT
- +4 ;
- VF3 ;
- +1 IF BMCVI<2
- SET BMCSTR=$EXTRACT(BMCVNM)_$$LOW^XLFSTR($EXTRACT(BMCVNM,2,99))
- DO SET
- IF $DATA(BMCQUIT)
- QUIT
- +2 KILL BMCAR
- DO ENP^XBDIQ1(BMCVFLE,BMCVDFN,".01;.06","BMCAR(","E")
- +3 SET Y=BMCAR(.01)_" - "_BMCAR(.06)
- SET BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,3,$LENGTH(Y))
- DO SET
- IF $DATA(BMCQUIT)
- QUIT
- +4 QUIT
- S ;
- +1 SET (C,F)=0
- FOR
- SET F=$ORDER(BMCAR(F))
- IF F'=+F
- QUIT
- IF BMCAR(F)]""
- Begin DoDot:1
- +2 SET C=C+1
- SET Y=$EXTRACT($SELECT($GET(^DD(90001,F,.1))]"":$PIECE(^DD(90001,F,.1),U),1:$PIECE(^DD(90001,F,0),U)),1,13)_": "
- SET Y=$EXTRACT(Y)_$$LOW^XLFSTR($EXTRACT(Y,2,999))
- SET BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,$PIECE(BMC1,",",C),$LENGTH(Y))
- +3 SET Y=$EXTRACT(BMCAR(F),1,20)
- SET BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,$PIECE(BMC2,",",C),$LENGTH(Y))
- End DoDot:1
- +4 DO SET
- IF $DATA(BMCQUIT)
- QUIT
- +5 QUIT
- BUILD1 ;
- +1 SET BMCSTR=$EXTRACT(BMCH,1,25)_":"
- SET BMCSTR=$$SETSTR^VALM1(BMCV,BMCSTR,28,$LENGTH(BMCV))
- +2 DO SET
- IF $DATA(BMCQUIT)
- QUIT
- +3 QUIT
- SET ;set array
- +1 IF $Y>(IOSL-3)
- IF BMCOPT'="B"
- DO HEAD
- IF $DATA(BMCQUIT)
- QUIT
- +2 WRITE !,BMCSTR
- +3 SET BMCSTR=""
- +4 QUIT
- +5 ;
- WP ;EP - Entry point to print wp fields pass node in BMCNODE
- +1 ;PASS FILE IN BMCFILE, ENTRY IN BMCREF
- +2 KILL ^UTILITY($JOB,"W")
- +3 SET BMCX=0
- +4 IF '$DATA(BMCG)
- SET BMCG=^DIC(BMCFILE,0,"GL")
- SET BMCG=BMCG_BMCREF_","_BMCNODE_",BMCX)"
- +5 SET DIWL=1
- SET DIWR=75
- SET DIWF="C75"
- FOR
- SET BMCX=$ORDER(@BMCG)
- IF BMCX'=+BMCX!($DATA(BMCQUIT))
- QUIT
- Begin DoDot:1
- +6 SET Y=$PIECE(BMCG,")")_",0)"
- SET X=@Y
- DO ^DIWP
- +7 QUIT
- End DoDot:1
- WPS ;EP
- +1 SET Z=0
- FOR
- SET Z=$ORDER(^UTILITY($JOB,"W",DIWL,Z))
- IF Z'=+Z!($DATA(BMCQUIT))
- QUIT
- SET BMCSTR=$$SETSTR^VALM1(^UTILITY($JOB,"W",DIWL,Z,0),BMCSTR,5,$LENGTH(^UTILITY($JOB,"W",DIWL,Z,0)))
- DO SET
- IF $DATA(BMCQUIT)
- QUIT
- +2 KILL DIWL,DIWR,DIWF,Z
- +3 KILL ^UTILITY($JOB,"W"),BMCNODE,BMCFILE,BMCG,BMCCOL
- +4 QUIT
- HEAD ;
- +1 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 !,"***** CONFIDENTIAL PATIENT INFORMATION ***** Referral Summary (TLOG) Page ",BMCPG
- +3 WRITE !,"Report Run Date: ",$$FMTE^XLFDT($$HTFM^XLFDT($HOROLOG),"1P")
- +4 WRITE !,BMC80D
- +5 QUIT