BMCRR121 ; IHS/PHXAO/TMJ - PROCESS REFERRAL LIST ; [ 09/27/2006 2:04 PM ]
;;4.0;REFERRED CARE INFO SYSTEM;**1**;JAN 09, 2006;Build 101
;
;4.0*1 3.8.06 IHS/OIT/FCJ ADDED SECTION TO PRNT ALPHA ORDER FOR PHYS
;
;
START ;
S (BMCBT,BMCBTH)=$H,BMCJOB=$J,BMCRCNT=0
D PROCESS,END
Q
;
PROCESS ;
V ; Run by visit date
S BMCODAT=$O(^AUPNVSIT("B",BMCSD)) I BMCODAT="" S BMCET=$H Q
S BMCODAT=BMCSD_".9999" F S BMCODAT=$O(^AUPNVSIT("B",BMCODAT)) Q:BMCODAT=""!((BMCODAT\1)>BMCED) D V1
S BMCODAT=$O(^BMCREF("B",BMCSD)) I BMCODAT="" S BMCET=$H Q
S BMCODAT=BMCSD_".9999" F S BMCODAT=$O(^BMCREF("B",BMCODAT)) Q:BMCODAT=""!((BMCODAT\1)>BMCED) D R1
;
;4.0*1 3.8.06 IHS/OIT/FCJ ADD NXT SECTION TO PRNT ALPHA ORDER FOR PHYS
I BMCTYPE="P",$D(^XTMP("BMCRR12",BMCJOB,BMCBTH,"REFERRALS")) D
.S BMCSORT=0
.F S BMCSORT=$O(^XTMP("BMCRR12",BMCJOB,BMCBTH,"REFERRALS",BMCSORT)) Q:BMCSORT'?1N.N D
..S ^XTMP("BMCRR12",BMCJOB,BMCBTH,"REFERRALS",$P($G(^VA(200,BMCSORT,0)),U),BMCSORT)=""
;4.0*1 3.8.06 IHS/OIT/FCJ END OF CHANGES
Q
;
END ;
S BMCET=$H
Q
V1 ;
S BMCVDFN="" F S BMCVDFN=$O(^AUPNVSIT("B",BMCODAT,BMCVDFN)) Q:BMCVDFN'=+BMCVDFN I $D(^AUPNVSIT(BMCVDFN,0)) S BMCVREC=^(0) D PROCV
Q
;
R1 ;
S BMCREF="" F S BMCREF=$O(^BMCREF("B",BMCODAT,BMCREF)) Q:BMCREF'=+BMCREF S BMCRREC=^BMCREF(BMCREF,0) D PROCR
Q
PROCR ;
Q:$P(BMCRREC,U,4)="N" ;skip in house referrals
Q:$P(BMCRREC,U,15)="X" ;skip cancelled referrals
Q:$P(BMCRREC,U,6)=""
Q:$P(BMCRREC,U,5)=""
S BMCSORT=$S(BMCTYPE="P":$P(BMCRREC,U,6),1:$P(BMCRREC,U,5))
I '$D(^XTMP("BMCRR12",BMCJOB,BMCBTH,"REFERRALS",BMCSORT)) S ^XTMP("BMCRR12",BMCJOB,BMCBTH,"REFERRALS",BMCSORT)=""
S $P(^XTMP("BMCRR12",BMCJOB,BMCBTH,"REFERRALS",BMCSORT),U)=$P(^XTMP("BMCRR12",BMCJOB,BMCBTH,"REFERRALS",BMCSORT),U)+1
Q:$P(BMCRREC,U,4)'="C"
S $P(^XTMP("BMCRR12",BMCJOB,BMCBTH,"REFERRALS",BMCSORT),U,2)=$P(^XTMP("BMCRR12",BMCJOB,BMCBTH,"REFERRALS",BMCSORT),U,2)+1
I BMCTCOST="B" S $P(^XTMP("BMCRR12",BMCJOB,BMCBTH,"REFERRALS",BMCSORT),U,3)=$P(^XTMP("BMCRR12",BMCJOB,BMCBTH,"REFERRALS",BMCSORT),U,3)+$$AVICOST^BMCRLU(BMCREF)
I BMCTCOST="A" S $P(^XTMP("BMCRR12",BMCJOB,BMCBTH,"REFERRALS",BMCSORT),U,3)=$P(^XTMP("BMCRR12",BMCJOB,BMCBTH,"REFERRALS",BMCSORT),U,3)+$P($G(^BMCREF(BMCREF,11)),U,18)
Q
PROCV ;
Q:'$P(BMCVREC,U,9)
Q:$P(BMCVREC,U,11)
Q:"TCNEDXF"[$P(BMCVREC,U,7)
Q:'$D(^AUPNVPOV("AD",BMCVDFN))
Q:'$D(^AUPNVPRV("AD",BMCVDFN))
Q:"CV"[$P(BMCVREC,U,3)
D @BMCTYPE
Q:BMCSORT="" ;couldn't find fac or provider
S ^(BMCSORT)=$S($D(^XTMP("BMCRR12",BMCJOB,BMCBTH,"PCC VISITS",BMCSORT)):^(BMCSORT)+1,1:1)
Q
F ;
S BMCSORT=$P(BMCVREC,U,6) Q:BMCSORT=""
Q
P ;
S BMC2=0,BMCSORT="" F S BMC2=$O(^AUPNVPRV("AD",BMCVDFN,BMC2)) Q:BMC2="" I $P(^AUPNVPRV(BMC2,0),U,4)="P" S BMCSORT=$P(^(0),U)
;if pcc converted to file 200 quit
;if pcc not converted, get 200 pointer from 16 pointer
Q:'BMCSORT
Q:$P(^AUTTSITE(1,0),U,22) ;TEST For file 200 conversion
S BMCSORT=$G(^DIC(16,BMCSORT,"A3"))
Q
BMCRR121 ; IHS/PHXAO/TMJ - PROCESS REFERRAL LIST ; [ 09/27/2006 2:04 PM ]
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**1**;JAN 09, 2006;Build 101
+2 ;
+3 ;4.0*1 3.8.06 IHS/OIT/FCJ ADDED SECTION TO PRNT ALPHA ORDER FOR PHYS
+4 ;
+5 ;
START ;
+1 SET (BMCBT,BMCBTH)=$HOROLOG
SET BMCJOB=$JOB
SET BMCRCNT=0
+2 DO PROCESS
DO END
+3 QUIT
+4 ;
PROCESS ;
V ; Run by visit date
+1 SET BMCODAT=$ORDER(^AUPNVSIT("B",BMCSD))
IF BMCODAT=""
SET BMCET=$HOROLOG
QUIT
+2 SET BMCODAT=BMCSD_".9999"
FOR
SET BMCODAT=$ORDER(^AUPNVSIT("B",BMCODAT))
IF BMCODAT=""!((BMCODAT\1)>BMCED)
QUIT
DO V1
+3 SET BMCODAT=$ORDER(^BMCREF("B",BMCSD))
IF BMCODAT=""
SET BMCET=$HOROLOG
QUIT
+4 SET BMCODAT=BMCSD_".9999"
FOR
SET BMCODAT=$ORDER(^BMCREF("B",BMCODAT))
IF BMCODAT=""!((BMCODAT\1)>BMCED)
QUIT
DO R1
+5 ;
+6 ;4.0*1 3.8.06 IHS/OIT/FCJ ADD NXT SECTION TO PRNT ALPHA ORDER FOR PHYS
+7 IF BMCTYPE="P"
IF $DATA(^XTMP("BMCRR12",BMCJOB,BMCBTH,"REFERRALS"))
Begin DoDot:1
+8 SET BMCSORT=0
+9 FOR
SET BMCSORT=$ORDER(^XTMP("BMCRR12",BMCJOB,BMCBTH,"REFERRALS",BMCSORT))
IF BMCSORT'?1N.N
QUIT
Begin DoDot:2
+10 SET ^XTMP("BMCRR12",BMCJOB,BMCBTH,"REFERRALS",$PIECE($GET(^VA(200,BMCSORT,0)),U),BMCSORT)=""
End DoDot:2
End DoDot:1
+11 ;4.0*1 3.8.06 IHS/OIT/FCJ END OF CHANGES
+12 QUIT
+13 ;
END ;
+1 SET BMCET=$HOROLOG
+2 QUIT
V1 ;
+1 SET BMCVDFN=""
FOR
SET BMCVDFN=$ORDER(^AUPNVSIT("B",BMCODAT,BMCVDFN))
IF BMCVDFN'=+BMCVDFN
QUIT
IF $DATA(^AUPNVSIT(BMCVDFN,0))
SET BMCVREC=^(0)
DO PROCV
+2 QUIT
+3 ;
R1 ;
+1 SET BMCREF=""
FOR
SET BMCREF=$ORDER(^BMCREF("B",BMCODAT,BMCREF))
IF BMCREF'=+BMCREF
QUIT
SET BMCRREC=^BMCREF(BMCREF,0)
DO PROCR
+2 QUIT
PROCR ;
+1 ;skip in house referrals
IF $PIECE(BMCRREC,U,4)="N"
QUIT
+2 ;skip cancelled referrals
IF $PIECE(BMCRREC,U,15)="X"
QUIT
+3 IF $PIECE(BMCRREC,U,6)=""
QUIT
+4 IF $PIECE(BMCRREC,U,5)=""
QUIT
+5 SET BMCSORT=$SELECT(BMCTYPE="P":$PIECE(BMCRREC,U,6),1:$PIECE(BMCRREC,U,5))
+6 IF '$DATA(^XTMP("BMCRR12",BMCJOB,BMCBTH,"REFERRALS",BMCSORT))
SET ^XTMP("BMCRR12",BMCJOB,BMCBTH,"REFERRALS",BMCSORT)=""
+7 SET $PIECE(^XTMP("BMCRR12",BMCJOB,BMCBTH,"REFERRALS",BMCSORT),U)=$PIECE(^XTMP("BMCRR12",BMCJOB,BMCBTH,"REFERRALS",BMCSORT),U)+1
+8 IF $PIECE(BMCRREC,U,4)'="C"
QUIT
+9 SET $PIECE(^XTMP("BMCRR12",BMCJOB,BMCBTH,"REFERRALS",BMCSORT),U,2)=$PIECE(^XTMP("BMCRR12",BMCJOB,BMCBTH,"REFERRALS",BMCSORT),U,2)+1
+10 IF BMCTCOST="B"
SET $PIECE(^XTMP("BMCRR12",BMCJOB,BMCBTH,"REFERRALS",BMCSORT),U,3)=$PIECE(^XTMP("BMCRR12",BMCJOB,BMCBTH,"REFERRALS",BMCSORT),U,3)+$$AVICOST^BMCRLU(BMCREF)
+11 IF BMCTCOST="A"
SET $PIECE(^XTMP("BMCRR12",BMCJOB,BMCBTH,"REFERRALS",BMCSORT),U,3)=$PIECE(^XTMP("BMCRR12",BMCJOB,BMCBTH,"REFERRALS",BMCSORT),U,3)+$PIECE($GET(^BMCREF(BMCREF,11)),U,18)
+12 QUIT
PROCV ;
+1 IF '$PIECE(BMCVREC,U,9)
QUIT
+2 IF $PIECE(BMCVREC,U,11)
QUIT
+3 IF "TCNEDXF"[$PIECE(BMCVREC,U,7)
QUIT
+4 IF '$DATA(^AUPNVPOV("AD",BMCVDFN))
QUIT
+5 IF '$DATA(^AUPNVPRV("AD",BMCVDFN))
QUIT
+6 IF "CV"[$PIECE(BMCVREC,U,3)
QUIT
+7 DO @BMCTYPE
+8 ;couldn't find fac or provider
IF BMCSORT=""
QUIT
+9 SET ^(BMCSORT)=$SELECT($DATA(^XTMP("BMCRR12",BMCJOB,BMCBTH,"PCC VISITS",BMCSORT)):^(BMCSORT)+1,1:1)
+10 QUIT
F ;
+1 SET BMCSORT=$PIECE(BMCVREC,U,6)
IF BMCSORT=""
QUIT
+2 QUIT
P ;
+1 SET BMC2=0
SET BMCSORT=""
FOR
SET BMC2=$ORDER(^AUPNVPRV("AD",BMCVDFN,BMC2))
IF BMC2=""
QUIT
IF $PIECE(^AUPNVPRV(BMC2,0),U,4)="P"
SET BMCSORT=$PIECE(^(0),U)
+2 ;if pcc converted to file 200 quit
+3 ;if pcc not converted, get 200 pointer from 16 pointer
+4 IF 'BMCSORT
QUIT
+5 ;TEST For file 200 conversion
IF $PIECE(^AUTTSITE(1,0),U,22)
QUIT
+6 SET BMCSORT=$GET(^DIC(16,BMCSORT,"A3"))
+7 QUIT
