BRNACT.m

BRNACT ; IHS/OIT/GAB - ROI PATIENT ACCOUNTING OF DISCLOSURE REPORT; 

 ;;2.0;IHS RELEASE OF INFORMATION;**4**;APR 10, 2003 ;Build 15

 ;;IHS/OIT/GAB 09/01/16 PATCH #4 ADDED THIS REPORT

SERVICE ;PICK PATIENT NAME ENTRY

 NEW BRNPTN,BRNBD,BRNED,BRNDT,BRNDAT,BRNFIND,BRNQUIT,X

 W !!

 S DIC=2 S DIC("A")="Enter a Patient Name: " S DIC(0)="AEMIQO" D ^DIC

 G END:Y<1 S BRNPTN=+Y

 I BRNPTN="" Q

 I '$D(^BRNREC("AA",BRNPTN)) W !,?20,"**--NO EXISTING DISCLOSURES--**",! Q

ASK ;Ask For Date Range

 ;

 ;

BD ;get beginning date

 W !! S DIR(0)="D^:"_DT_":EP",DIR("A")="Enter beginning ROI Initiated Date" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) G END

 S BRNBD=Y

ED ;get ending date

 W ! S DIR(0)="D^"_BRNBD_":"_DT_":EP",DIR("A")="Enter ending ROI Initiation Date"  D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) G BD

 S BRNED=Y

 S BRNED=BRNED_.2359

 S X1=BRNBD,X2=-1 D C^%DTC S BRNSD=X

 ; 

PRINT ;PRINT PATIENT RECORD OF ALL DISCLOSURES BY DATE

 N DIC,L,FLDS,BY,FR,TO

 S FLDS="[BRN ACCOUNTING OF DISCLOSURES]",BY="@INTERNAL(#.01),@INTERNAL(#.03)",DIC="^BRNREC(",L=0

 S FR=BRNBD_","_BRNPTN,TO=BRNED_","_BRNPTN

 K DHIT,DIOEND,DIOBEG

 D CKROI

 I BRNFIND=0 W !!,"       ***No disclosures to print in this date range***   ",! G END

 D EN1^DIP

 D PAUSE^XB

 D END

 Q

CKROI ; IHS/OIT/GAB CHECK FOR DISCLOSURES IN THE DATE RANGE TO PREVENT ERROR

 S BRNDT=BRNBD    ;start looking in the date range

 S BRNDAT=""

 S BRNFIND=0

 F  S BRNDT=$O(^BRNREC("AA",BRNPTN,BRNDT)) Q:BRNDT=""!BRNFIND=1  D

 . S BRNDAT=$P(BRNDT,".",1)

 . Q:BRNDAT>BRNED

 . I (BRNDAT>(BRNBD-1)&&((BRNDAT-1)<BRNED)) S BRNFIND=1 Q

 Q

END ;

 K BRNPTN,BRNED,BRNBD,BRNSD,X,DD0,B Q

BRNACT    ; IHS/OIT/GAB - ROI PATIENT ACCOUNTING OF DISCLOSURE REPORT; 

 +1       ;;2.0;IHS RELEASE OF INFORMATION;**4**;APR 10, 2003 ;Build 15

 +2       ;;IHS/OIT/GAB 09/01/16 PATCH #4 ADDED THIS REPORT

SERVICE   ;PICK PATIENT NAME ENTRY

 +1        NEW BRNPTN,BRNBD,BRNED,BRNDT,BRNDAT,BRNFIND,BRNQUIT,X

 +2        WRITE !!

 +3        SET DIC=2

           SET DIC("A")="Enter a Patient Name: "

           SET DIC(0)="AEMIQO"

           DO ^DIC

 +4        IF Y<1

               GOTO END

           SET BRNPTN=+Y

 +5        IF BRNPTN=""

               QUIT 

 +6        IF '$DATA(^BRNREC("AA",BRNPTN))

               WRITE !,?20,"**--NO EXISTING DISCLOSURES--**",!

               QUIT 

ASK       ;Ask For Date Range

 +1       ;

 +2       ;

BD        ;get beginning date

 +1        WRITE !!

           SET DIR(0)="D^:"_DT_":EP"

           SET DIR("A")="Enter beginning ROI Initiated Date"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DIRUT)

               GOTO END

 +3        SET BRNBD=Y

ED        ;get ending date

 +1        WRITE !

           SET DIR(0)="D^"_BRNBD_":"_DT_":EP"

           SET DIR("A")="Enter ending ROI Initiation Date"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DIRUT)

               GOTO BD

 +3        SET BRNED=Y

 +4        SET BRNED=BRNED_.2359

 +5        SET X1=BRNBD

           SET X2=-1

           DO C^%DTC

           SET BRNSD=X

 +6       ; 

PRINT     ;PRINT PATIENT RECORD OF ALL DISCLOSURES BY DATE

 +1        NEW DIC,L,FLDS,BY,FR,TO

 +2        SET FLDS="[BRN ACCOUNTING OF DISCLOSURES]"

           SET BY="@INTERNAL(#.01),@INTERNAL(#.03)"

           SET DIC="^BRNREC("

           SET L=0

 +3        SET FR=BRNBD_","_BRNPTN

           SET TO=BRNED_","_BRNPTN

 +4        KILL DHIT,DIOEND,DIOBEG

 +5        DO CKROI

 +6        IF BRNFIND=0

               WRITE !!,"       ***No disclosures to print in this date range***   ",!

               GOTO END

 +7        DO EN1^DIP

 +8        DO PAUSE^XB

 +9        DO END

 +10       QUIT 

CKROI     ; IHS/OIT/GAB CHECK FOR DISCLOSURES IN THE DATE RANGE TO PREVENT ERROR

 +1       ;start looking in the date range

           SET BRNDT=BRNBD

 +2        SET BRNDAT=""

 +3        SET BRNFIND=0

 +4        FOR 

               SET BRNDT=$ORDER(^BRNREC("AA",BRNPTN,BRNDT))

               IF BRNDT=""!BRNFIND=1

                   QUIT 

               Begin DoDot:1

 +5                SET BRNDAT=$PIECE(BRNDT,".",1)

 +6                IF BRNDAT>BRNED

                       QUIT 

 +7                IF (BRNDAT>(BRNBD-1)&&((BRNDAT-1)<BRNED))

                       SET BRNFIND=1

                       QUIT 

               End DoDot:1

 +8        QUIT 

END       ;

 +1        KILL BRNPTN,BRNED,BRNBD,BRNSD,X,DD0,B

           QUIT