BMCCLOS3.m

BMCCLOS3 ; IHS/OIT/FCJ - PROCESS REFERRAL CLOSURES ;    

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

 ;IHS/OIT/FCJ DO NOT SKIP SR;REWROTE ROUTINE TO PROVIDE DOS SORT

 ;

 ;

 ;

DRI ;DATE REF INITIATED

 S BMCCT=0,BMCODAT=BMCSD

 F  S BMCODAT=$O(^BMCREF("B",BMCODAT))  Q:(BMCODAT>BMCED)!(BMCODAT'=+BMCODAT)  D

 .S BMCREF="" F  S BMCREF=$O(^BMCREF("B",BMCODAT,BMCREF))  Q:BMCREF'=+BMCREF  D PROCESS

 D END Q

DOS ;DATE OF SERVICE SORT     

 S BMCCT=0,BMCODAT=BMCSD

 F  S BMCODAT=$O(^BMCREF("BA",BMCODAT)) Q:(BMCODAT>BMCED)!(BMCODAT'=+BMCODAT)  D

 .S BMCREF="" F  S BMCREF=$O(^BMCREF("BA",BMCODAT,BMCREF)) Q:BMCREF'?1N.N  D

 ..S BMCADOS=$P(^BMCREF(BMCREF,11),U,6)

 ..I BMCADOS=+BMCADOS Q:(BMCADOS<BMCSD)!(BMCADOS>BMCED)

 ..D PROCESS

 S BMCODAT=BMCSD

 F  S BMCODAT=$O(^BMCREF("BB",BMCODAT)) Q:(BMCODAT>BMCED)!(BMCODAT'=+BMCODAT)  D

 .S BMCREF="" F  S BMCREF=$O(^BMCREF("BB",BMCODAT,BMCREF)) Q:BMCREF'=+BMCREF  S BMCR="REC2" D PROCESS

 D END Q

PROCESS ;

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

 I BMCKIND'="A" Q:$P(BMCRREC,U,4)'=BMCKIND  ;Q NOT Ref Type

 Q:$P(BMCRREC,U,5)'=BMCFAC

 I $D(^BMCREF(BMCREF,21,"B",BMCLCAT)) Q

 S BMCRIEN=BMCREF

 S BMCTYPE=$P(BMCRREC,U,14)

 Q:BMCTYPE=""

 I BMCTYP'="B" Q:BMCTYP'=BMCTYPE  ;Q if Inpt/Outpt does not Match Ref

 Q:$$VALI^XBDIQ1(90001,BMCRIEN,".15")="C1"  ;Quit if already closed

 S BMCADOS=$$VALI^XBDIQ1(90001,BMCRIEN,1106)

 S BMCCLS=$S(BMCADOS="":"X",1:"C1")

 S DA=BMCRIEN,DIE="^BMCREF(",DR=".15////"_BMCCLS D ^DIE K DIE

 W !,?10,"Closed Referral #: "_$P(^BMCREF(BMCRIEN,0),U,2)

 W ?55,"IEN #: "_BMCRIEN W !

 S BMCCT=BMCCT+1

 Q

 ;

 ;

PCCL ;PCC Link - No Need to Link these Visits - CHS Visit Closure ONLY

 ;I $$VALI^XBDIQ1(90001,BMCRIEN,".15")="C1" D ^BMCPCCL

 ;

END ;End of Closure

 W !,"End of Auto Close of Referrals - Total Number of Referrals Closed = "_BMCCT

 Q

BMCCLOS3  ; IHS/OIT/FCJ - PROCESS REFERRAL CLOSURES ;    

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

 +2       ;IHS/OIT/FCJ DO NOT SKIP SR;REWROTE ROUTINE TO PROVIDE DOS SORT

 +3       ;

 +4       ;

 +5       ;

DRI       ;DATE REF INITIATED

 +1        SET BMCCT=0

           SET BMCODAT=BMCSD

 +2        FOR 

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

               IF (BMCODAT>BMCED)!(BMCODAT'=+BMCODAT)

                   QUIT 

               Begin DoDot:1

 +3                SET BMCREF=""

                   FOR 

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

                       IF BMCREF'=+BMCREF

                           QUIT 

                       DO PROCESS

               End DoDot:1

 +4        DO END

           QUIT 

DOS       ;DATE OF SERVICE SORT     

 +1        SET BMCCT=0

           SET BMCODAT=BMCSD

 +2        FOR 

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

               IF (BMCODAT>BMCED)!(BMCODAT'=+BMCODAT)

                   QUIT 

               Begin DoDot:1

 +3                SET BMCREF=""

                   FOR 

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

                       IF BMCREF'?1N.N

                           QUIT 

                       Begin DoDot:2

 +4                        SET BMCADOS=$PIECE(^BMCREF(BMCREF,11),U,6)

 +5                        IF BMCADOS=+BMCADOS

                               IF (BMCADOS<BMCSD)!(BMCADOS>BMCED)

                                   QUIT 

 +6                        DO PROCESS

                       End DoDot:2

               End DoDot:1

 +7        SET BMCODAT=BMCSD

 +8        FOR 

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

               IF (BMCODAT>BMCED)!(BMCODAT'=+BMCODAT)

                   QUIT 

               Begin DoDot:1

 +9                SET BMCREF=""

                   FOR 

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

                       IF BMCREF'=+BMCREF

                           QUIT 

                       SET BMCR="REC2"

                       DO PROCESS

               End DoDot:1

 +10       DO END

           QUIT 

PROCESS   ;

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

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

 +2       ;Q NOT Ref Type

           IF BMCKIND'="A"

               IF $PIECE(BMCRREC,U,4)'=BMCKIND

                   QUIT 

 +3        IF $PIECE(BMCRREC,U,5)'=BMCFAC

               QUIT 

 +4        IF $DATA(^BMCREF(BMCREF,21,"B",BMCLCAT))

               QUIT 

 +5        SET BMCRIEN=BMCREF

 +6        SET BMCTYPE=$PIECE(BMCRREC,U,14)

 +7        IF BMCTYPE=""

               QUIT 

 +8       ;Q if Inpt/Outpt does not Match Ref

           IF BMCTYP'="B"

               IF BMCTYP'=BMCTYPE

                   QUIT 

 +9       ;Quit if already closed

           IF $$VALI^XBDIQ1(90001,BMCRIEN,".15")="C1"

               QUIT 

 +10       SET BMCADOS=$$VALI^XBDIQ1(90001,BMCRIEN,1106)

 +11       SET BMCCLS=$SELECT(BMCADOS="":"X",1:"C1")

 +12       SET DA=BMCRIEN

           SET DIE="^BMCREF("

           SET DR=".15////"_BMCCLS

           DO ^DIE

           KILL DIE

 +13       WRITE !,?10,"Closed Referral #: "_$PIECE(^BMCREF(BMCRIEN,0),U,2)

 +14       WRITE ?55,"IEN #: "_BMCRIEN

           WRITE !

 +15       SET BMCCT=BMCCT+1

 +16       QUIT 

 +17      ;

 +18      ;

PCCL      ;PCC Link - No Need to Link these Visits - CHS Visit Closure ONLY

 +1       ;I $$VALI^XBDIQ1(90001,BMCRIEN,".15")="C1" D ^BMCPCCL

 +2       ;

END       ;End of Closure

 +1        WRITE !,"End of Auto Close of Referrals - Total Number of Referrals Closed = "_BMCCT

 +2        QUIT