- 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