BMCRR41.m

BMCRR41 ; IHS/PHXAO/TMJ - PROCESS REFERRAL LIST ;     [ 09/27/2006  2:15 PM ]

 ;;4.0;REFERRED CARE INFO SYSTEM;**1**;JAN 09, 2006;Build 101

 ;IHS/ITSC/FCJ ADDED TEST FOR SR

 ;4.0*1 3.7.06 IHS/OIT/FCJ ADDED 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.7.06 IHS/OIT/FCJ ADD SECTION TO PRNT ALPHA ORDER FOR PHYS

 I BMCTYPE="P",$D(^XTMP("BMCRR4",BMCJOB,BMCBTH,"REFERRALS")) D

 .S BMCSORT=0

 .F  S BMCSORT=$O(^XTMP("BMCRR4",BMCJOB,BMCBTH,"REFERRALS",BMCSORT)) Q:BMCSORT'?1N.N  D

 ..S ^XTMP("BMCRR4",BMCJOB,BMCBTH,"REFERRALS",$P($G(^VA(200,BMCSORT,0)),U),BMCSORT)=""

 ;4.0*1 3.7.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"

 Q:$P(BMCRREC,U,15)="X"  ;skip cancelled referrals

 Q:$P(BMCRREC,U,6)=""

 Q:$P(BMCRREC,U,5)=""

 Q:$P($G(^BMCREF(BMCREF,1)),U)'=""  ;SKIP SR

 S BMCSORT=$S(BMCTYPE="P":$P(BMCRREC,U,6),1:$P(BMCRREC,U,5))

 I '$D(^XTMP("BMCRR4",BMCJOB,BMCBTH,"REFERRALS",BMCSORT)) S ^XTMP("BMCRR4",BMCJOB,BMCBTH,"REFERRALS",BMCSORT)=""

 S $P(^XTMP("BMCRR4",BMCJOB,BMCBTH,"REFERRALS",BMCSORT),U)=$P(^XTMP("BMCRR4",BMCJOB,BMCBTH,"REFERRALS",BMCSORT),U)+1

 ;S $P(^XTMP("BMCRR4",BMCJOB,BMCBTH,"REFERRALS",BMCSORT),U,2)=$P(^XTMP("BMCRR4",BMCJOB,BMCBTH,"REFERRALS",BMCSORT),U,2)+$$AVICOST^BMCRLU(BMCREF)

 Q:$P(BMCRREC,U,4)=""

 S X=$S($P(BMCRREC,U,4)="I":2,$P(BMCRREC,U,4)="O":3,$P(BMCRREC,U,4)="C":4)

 S $P(^XTMP("BMCRR4",BMCJOB,BMCBTH,"REFERRALS",BMCSORT),U,X)=$P(^XTMP("BMCRR4",BMCJOB,BMCBTH,"REFERRALS",BMCSORT),U,X)+1

 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("BMCRR4",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

BMCRR41   ; IHS/PHXAO/TMJ - PROCESS REFERRAL LIST ;     [ 09/27/2006  2:15 PM ]

 +1       ;;4.0;REFERRED CARE INFO SYSTEM;**1**;JAN 09, 2006;Build 101

 +2       ;IHS/ITSC/FCJ ADDED TEST FOR SR

 +3       ;4.0*1 3.7.06 IHS/OIT/FCJ ADDED 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       ;4.0*1 3.7.06 IHS/OIT/FCJ ADD SECTION TO PRNT ALPHA ORDER FOR PHYS

 +6        IF BMCTYPE="P"

               IF $DATA(^XTMP("BMCRR4",BMCJOB,BMCBTH,"REFERRALS"))

                   Begin DoDot:1

 +7                    SET BMCSORT=0

 +8                    FOR 

                           SET BMCSORT=$ORDER(^XTMP("BMCRR4",BMCJOB,BMCBTH,"REFERRALS",BMCSORT))

                           IF BMCSORT'?1N.N

                               QUIT 

                           Begin DoDot:2

 +9                            SET ^XTMP("BMCRR4",BMCJOB,BMCBTH,"REFERRALS",$PIECE($GET(^VA(200,BMCSORT,0)),U),BMCSORT)=""

                           End DoDot:2

                   End DoDot:1

 +10      ;4.0*1 3.7.06 IHS/OIT/FCJ END OF CHANGES

 +11       QUIT 

 +12      ;

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        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       ;SKIP SR

           IF $PIECE($GET(^BMCREF(BMCREF,1)),U)'=""

               QUIT 

 +6        SET BMCSORT=$SELECT(BMCTYPE="P":$PIECE(BMCRREC,U,6),1:$PIECE(BMCRREC,U,5))

 +7        IF '$DATA(^XTMP("BMCRR4",BMCJOB,BMCBTH,"REFERRALS",BMCSORT))

               SET ^XTMP("BMCRR4",BMCJOB,BMCBTH,"REFERRALS",BMCSORT)=""

 +8        SET $PIECE(^XTMP("BMCRR4",BMCJOB,BMCBTH,"REFERRALS",BMCSORT),U)=$PIECE(^XTMP("BMCRR4",BMCJOB,BMCBTH,"REFERRALS",BMCSORT),U)+1

 +9       ;S $P(^XTMP("BMCRR4",BMCJOB,BMCBTH,"REFERRALS",BMCSORT),U,2)=$P(^XTMP("BMCRR4",BMCJOB,BMCBTH,"REFERRALS",BMCSORT),U,2)+$$AVICOST^BMCRLU(BMCREF)

 +10       IF $PIECE(BMCRREC,U,4)=""

               QUIT 

 +11       SET X=$SELECT($PIECE(BMCRREC,U,4)="I":2,$PIECE(BMCRREC,U,4)="O":3,$PIECE(BMCRREC,U,4)="C":4)

 +12       SET $PIECE(^XTMP("BMCRR4",BMCJOB,BMCBTH,"REFERRALS",BMCSORT),U,X)=$PIECE(^XTMP("BMCRR4",BMCJOB,BMCBTH,"REFERRALS",BMCSORT),U,X)+1

 +13       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("BMCRR4",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