BMCRR61.m

BMCRR61 ; IHS/PHXAO/TMJ - PROCESS REFERRAL LIST ;   

 ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006

 ;IHS/ITSC/FCJ ADDED TEST FOR SR

 ;

 ;

 ;

START ;

 S (BMCBT,BMCBTH)=$H,BMCJOB=$J,BMCRCNT=0

 D PROCESS,END

 Q

 ;

PROCESS ;

V ; Run by visit date

 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

 Q

 ;

END ;

 S BMCET=$H

 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)'="C1"  ;must be a completed-action done referral

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

 S BMCSVCD=$$AVEOS^BMCRLU(BMCREF,"I")

 Q:BMCSVCD=""  ;quit if no end date of service is available

 S BMCF=$$FACREF^BMCRLU(BMCREF)

 I '$D(^XTMP("BMCRR6",BMCJOB,BMCBTH,"REFERRALS",BMCF)) D

 .F %=1:1:6 S $P(^XTMP("BMCRR6",BMCJOB,BMCBTH,"REFERRALS",BMCF),U,%)=0

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

 S BMCD=$P(BMCRREC,U,18)

 I BMCD="" S $P(^XTMP("BMCRR6",BMCJOB,BMCBTH,"REFERRALS",BMCF),U,2)=$P(^XTMP("BMCRR6",BMCJOB,BMCBTH,"REFERRALS",BMCF),U,2)+1 Q

 S X=$$FMDIFF^XLFDT(BMCD,BMCSVCD,1)

 S %=$S(X>181:6,X>94:5,X>32:4,1:3)

 S $P(^XTMP("BMCRR6",BMCJOB,BMCBTH,"REFERRALS",BMCF),U,%)=$P(^XTMP("BMCRR6",BMCJOB,BMCBTH,"REFERRALS",BMCF),U,%)+1

 Q

BMCRR61   ; IHS/PHXAO/TMJ - PROCESS REFERRAL LIST ;   

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

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

 +3       ;

 +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(^BMCREF("B",BMCSD))

           IF BMCODAT=""

               SET BMCET=$HOROLOG

               QUIT 

 +2        SET BMCODAT=BMCSD_".9999"

           FOR 

               SET BMCODAT=$ORDER(^BMCREF("B",BMCODAT))

               IF BMCODAT=""!((BMCODAT\1)>BMCED)

                   QUIT 

               DO R1

 +3        QUIT 

 +4       ;

END       ;

 +1        SET BMCET=$HOROLOG

 +2        QUIT 

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       ;must be a completed-action done referral

           IF $PIECE(BMCRREC,U,15)'="C1"

               QUIT 

 +3       ;QUIT IF SR

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

               QUIT 

 +4        SET BMCSVCD=$$AVEOS^BMCRLU(BMCREF,"I")

 +5       ;quit if no end date of service is available

           IF BMCSVCD=""

               QUIT 

 +6        SET BMCF=$$FACREF^BMCRLU(BMCREF)

 +7        IF '$DATA(^XTMP("BMCRR6",BMCJOB,BMCBTH,"REFERRALS",BMCF))

               Begin DoDot:1

 +8                FOR %=1:1:6

                       SET $PIECE(^XTMP("BMCRR6",BMCJOB,BMCBTH,"REFERRALS",BMCF),U,%)=0

               End DoDot:1

 +9        SET $PIECE(^XTMP("BMCRR6",BMCJOB,BMCBTH,"REFERRALS",BMCF),U)=$PIECE(^XTMP("BMCRR6",BMCJOB,BMCBTH,"REFERRALS",BMCF),U)+1

 +10       SET BMCD=$PIECE(BMCRREC,U,18)

 +11       IF BMCD=""

               SET $PIECE(^XTMP("BMCRR6",BMCJOB,BMCBTH,"REFERRALS",BMCF),U,2)=$PIECE(^XTMP("BMCRR6",BMCJOB,BMCBTH,"REFERRALS",BMCF),U,2)+1

               QUIT 

 +12       SET X=$$FMDIFF^XLFDT(BMCD,BMCSVCD,1)

 +13       SET %=$SELECT(X>181:6,X>94:5,X>32:4,1:3)

 +14       SET $PIECE(^XTMP("BMCRR6",BMCJOB,BMCBTH,"REFERRALS",BMCF),U,%)=$PIECE(^XTMP("BMCRR6",BMCJOB,BMCBTH,"REFERRALS",BMCF),U,%)+1

 +15       QUIT