BMCRR131.m

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

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

 ;IHS/ITSC/FCJ ADDED SORT BY BEG AND END DATE OF REF INITIATED

 ;

START ;

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

 D PROCESS,END

 Q

 ;

PROCESS ;

 ;S BMCREF=0 F  S BMCREF=$O(^BMCREF("AB","A",BMCREF)) Q:BMCREF'=+BMCREF  D PROC

 ;

 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

 ;

R1 ;

 S BMCREF="" F  S BMCREF=$O(^BMCREF("B",BMCODAT,BMCREF)) Q:BMCREF'=+BMCREF  S BMCRREC=^BMCREF(BMCREF,0) D PROC

 Q

 ;

END ;

 S BMCET=$H

 Q

PROC ;

 S BMCRREC=^BMCREF(BMCREF,0),DFN=$P(BMCRREC,U,3)

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

 ;Q:$P(BMCRREC,U,15)'="A"  ;BMC*4.0*9 IHS.OIT.FCJ

 Q:($P(BMCRREC,U,15)="C1")!($P(BMCRREC,U,15)="X")  ;QUIT IF NOT ACTIVE OR APPROVED ;BMC*4.0*9 IHS.OIT.FCJ

 ;get sort value

 I $G(BMCPROV),BMCPROV'=$P(BMCRREC,U,6) Q

 S BMCPRV=$P(BMCRREC,U,6) S:BMCPRV BMCPRV=$P($G(^VA(200,BMCPRV,0)),U) S:BMCPRV="" BMCPRV="--"

 S ^XTMP("BMCRR13",BMCJOB,BMCBTH,"DATA HITS",BMCPRV,BMCREF)="",BMCRCNT=BMCRCNT+1

 Q

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

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

 +2       ;IHS/ITSC/FCJ ADDED SORT BY BEG AND END DATE OF REF INITIATED

 +3       ;

START     ;

 +1        SET (BMCBT,BMCBTH)=$HOROLOG

           SET BMCJOB=$JOB

           SET BMCRCNT=0

 +2        DO PROCESS

           DO END

 +3        QUIT 

 +4       ;

PROCESS   ;

 +1       ;S BMCREF=0 F  S BMCREF=$O(^BMCREF("AB","A",BMCREF)) Q:BMCREF'=+BMCREF  D PROC

 +2       ;

 +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        QUIT 

 +6       ;

R1        ;

 +1        SET BMCREF=""

           FOR 

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

               IF BMCREF'=+BMCREF

                   QUIT 

               SET BMCRREC=^BMCREF(BMCREF,0)

               DO PROC

 +2        QUIT 

 +3       ;

END       ;

 +1        SET BMCET=$HOROLOG

 +2        QUIT 

PROC      ;

 +1        SET BMCRREC=^BMCREF(BMCREF,0)

           SET DFN=$PIECE(BMCRREC,U,3)

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

               QUIT 

 +3       ;Q:$P(BMCRREC,U,15)'="A"  ;BMC*4.0*9 IHS.OIT.FCJ

 +4       ;QUIT IF NOT ACTIVE OR APPROVED ;BMC*4.0*9 IHS.OIT.FCJ

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

               QUIT 

 +5       ;get sort value

 +6        IF $GET(BMCPROV)

               IF BMCPROV'=$PIECE(BMCRREC,U,6)

                   QUIT 

 +7        SET BMCPRV=$PIECE(BMCRREC,U,6)

           IF BMCPRV

               SET BMCPRV=$PIECE($GET(^VA(200,BMCPRV,0)),U)

           IF BMCPRV=""

               SET BMCPRV="--"

 +8        SET ^XTMP("BMCRR13",BMCJOB,BMCBTH,"DATA HITS",BMCPRV,BMCREF)=""

           SET BMCRCNT=BMCRCNT+1

 +9        QUIT