Routine: BDGSPTR

BDGSPTR ;cmi/anch/maw - BDG Sensitive Patient Tracking Report 6/3/2009 2:17:08 PM

 ;;5.3;PIMS;**1010,1011**;MAY 28, 2004

MAIN ;-- this is the main routine driver

 N BDGSPTS,BDGINDX

 S BDGSPTS=$$SORT()

 I $G(BDGSPTS)="" Q

 I BDGSPTS="S" S BDGSS=$$S()

 I BDGSPTS="S",+$G(BDGSS)<0 Q

 D LOOP(BDGSPTS)

 D PRINT(BDGSPTS)

 D EOJ

SORT() ;-- ask the sort for the report

 S DIR(0)="S^M:MAIL CODE;S:SERVICE SECTION",DIR("A")="Sort By ",DIR("B")="M"

 D ^DIR

 I Y=U Q ""

 S BDGSPTSE=Y(0)

Q Y

S() ;-- get service section

 S DIC=49,DIC(0)="AEMQZ",DIC("A")="Service/Section: "

 D ^DIC

 I 'Y Q ""

 Q +Y

LOOP(IDX) ;-- loop through the new person file

 N BDGDA

 S BDGDA=0 F  S BDGDA=$O(^BDGSPT("B",BDGDA)) Q:'BDGDA  D

 . N BDGIEN

 . S BDGIEN=0 F  S BDGIEN=$O(^BDGSPT("B",BDGDA,BDGIEN)) Q:'BDGIEN  D

 .. N BDGNM,BDGSSE,BDGMC,BDGI

 .. S BDGI=$P($G(^BDGSPT(BDGIEN,0)),U)

 .. S BDGNM=$P($G(^VA(200,BDGI,0)),U)

 .. S BDGSSE=$$GET1^DIQ(200,BDGI,29)

 .. I BDGSSE="" S BDGSSE="N/A"

 .. S BDGMC=$$GET1^DIQ(200,BDGI,28)

 .. I BDGMC="" S BDGMC="N/A"

 .. S ^TMP("BDGSPT",$J,$S(IDX="S":BDGSSE,1:BDGMC),BDGNM)=$S(IDX="S":BDGMC,1:BDGSSE)

PRINT(IDX) ;-- print the report

 D ^%ZIS

 Q:POP

 U IO

 D XHDR(IDX)

 N BDGTDA

 S BDGTDA=0 F  S BDGTDA=$O(^TMP("BDGSPT",$J,BDGTDA)) Q:BDGTDA=""  D

 . N BDGTIEN

 . S BDGTIEN=0 F  S BDGTIEN=$O(^TMP("BDGSPT",$J,BDGTDA,BDGTIEN)) Q:BDGTIEN=""  D

 .. N BDGDATA,BDGTSS,BDGTMC

 .. S BDGDATA=$G(^TMP("BDGSPT",$J,BDGTDA,BDGTIEN))

 .. S BDGTMC=$P(BDGDATA,U)

 .. D:$Y+2>IOSL HDR(IDX) Q:$G(DIRUT)

 .. W !,BDGTIEN,?35,BDGTDA,?55,BDGTMC

HDR(ID) ;-- do the charge header

 K DIRUT

 I $E(IOST,1,1)="C" S DIR(0)="E" D ^DIR I Y<1 S DIRUT=1 Q

XHDR(ID) W @IOF

 W "Sensitive Patient Tracking - Users Access by "_BDGSPTSE,?60,"Date:  "_$$FMTE^XLFDT(DT)

 W !!,"Name",?35,$S(ID="S":"Service Section",1:"Mail Code"),?55,$S(ID="S":"Mail Code",1:"Service/Section")

W !

 F I=1:1:80 W "-"

EOJ ;-- kill variables

 D ^%ZISC

 K BDGSPTSE

 K ^TMP("BDGSPT",$J)

BDGSPTR   ;cmi/anch/maw - BDG Sensitive Patient Tracking Report 6/3/2009 2:17:08 PM

 +1       ;;5.3;PIMS;**1010,1011**;MAY 28, 2004

 +2       ;

 +3       ;

 +4       ;

 +5       ;

MAIN      ;-- this is the main routine driver

 +1        NEW BDGSPTS,BDGINDX

 +2        SET BDGSPTS=$$SORT()

 +3        IF $GET(BDGSPTS)=""

               QUIT

 +4        IF BDGSPTS="S"

               SET BDGSS=$$S()

 +5        IF BDGSPTS="S"

               IF +$GET(BDGSS)<0

                   QUIT

 +6        DO LOOP(BDGSPTS)

 +7        DO PRINT(BDGSPTS)

 +8        DO EOJ

 +9        QUIT

 +10      ;

SORT()    ;-- ask the sort for the report

 +1        SET DIR(0)="S^M:MAIL CODE;S:SERVICE SECTION"

           SET DIR("A")="Sort By "

           SET DIR("B")="M"

 +2        DO ^DIR

 +3        IF Y=U

               QUIT ""

 +4        SET BDGSPTSE=Y(0)

 +5        QUIT Y

 +6       ;

S()       ;-- get service section

 +1        SET DIC=49

           SET DIC(0)="AEMQZ"

           SET DIC("A")="Service/Section: "

 +2        DO ^DIC

 +3        IF 'Y

               QUIT ""

 +4        QUIT +Y

 +5       ;

LOOP(IDX) ;-- loop through the new person file

 +1        NEW BDGDA

 +2        SET BDGDA=0

FOR

               SET BDGDA=$ORDER(^BDGSPT("B",BDGDA))

               IF 'BDGDA

                   QUIT

               Begin DoDot:1

 +3                NEW BDGIEN

 +4                SET BDGIEN=0

FOR

                       SET BDGIEN=$ORDER(^BDGSPT("B",BDGDA,BDGIEN))

                       IF 'BDGIEN

                           QUIT

                       Begin DoDot:2

 +5                        NEW BDGNM,BDGSSE,BDGMC,BDGI

 +6                        SET BDGI=$PIECE($GET(^BDGSPT(BDGIEN,0)),U)

 +7                        SET BDGNM=$PIECE($GET(^VA(200,BDGI,0)),U)

 +8                        SET BDGSSE=$$GET1^DIQ(200,BDGI,29)

 +9                        IF BDGSSE=""

                               SET BDGSSE="N/A"

 +10                       SET BDGMC=$$GET1^DIQ(200,BDGI,28)

 +11                       IF BDGMC=""

                               SET BDGMC="N/A"

 +12                       SET ^TMP("BDGSPT",$JOB,$SELECT(IDX="S":BDGSSE,1:BDGMC),BDGNM)=$SELECT(IDX="S":BDGMC,1:BDGSSE)

                       End DoDot:2

               End DoDot:1

 +13       QUIT

 +14      ;

PRINT(IDX) ;-- print the report

 +1        DO ^%ZIS

 +2        IF POP

               QUIT

 +3        USE IO

 +4        DO XHDR(IDX)

 +5        NEW BDGTDA

 +6        SET BDGTDA=0

FOR

               SET BDGTDA=$ORDER(^TMP("BDGSPT",$JOB,BDGTDA))

               IF BDGTDA=""

                   QUIT

               Begin DoDot:1

 +7                NEW BDGTIEN

 +8                SET BDGTIEN=0

FOR

                       SET BDGTIEN=$ORDER(^TMP("BDGSPT",$JOB,BDGTDA,BDGTIEN))

                       IF BDGTIEN=""

                           QUIT

                       Begin DoDot:2

 +9                        NEW BDGDATA,BDGTSS,BDGTMC

 +10                       SET BDGDATA=$GET(^TMP("BDGSPT",$JOB,BDGTDA,BDGTIEN))

 +11                       SET BDGTMC=$PIECE(BDGDATA,U)

 +12                       IF $Y+2>IOSL

                               DO HDR(IDX)

                           IF $GET(DIRUT)

                               QUIT

 +13                       WRITE !,BDGTIEN,?35,BDGTDA,?55,BDGTMC

                       End DoDot:2

               End DoDot:1

 +14       QUIT

 +15      ;

HDR(ID)   ;-- do the charge header

 +1        KILL DIRUT

 +2        IF $EXTRACT(IOST,1,1)="C"

               SET DIR(0)="E"

               DO ^DIR

               IF Y<1

                   SET DIRUT=1

                   QUIT

XHDR(ID)   WRITE @IOF

 +1        WRITE "Sensitive Patient Tracking - Users Access by "_BDGSPTSE,?60,"Date:  "_$$FMTE^XLFDT(DT)

 +2        WRITE !!,"Name",?35,$SELECT(ID="S":"Service Section",1:"Mail Code"),?55,$SELECT(ID="S":"Mail Code",1:"Service/Section")

 +3        WRITE !

 +4        FOR I=1:1:80

               WRITE "-"

 +5        QUIT

 +6       ;

EOJ       ;-- kill variables

 +1        DO ^%ZISC

 +2        KILL BDGSPTSE

 +3        KILL ^TMP("BDGSPT",$JOB)

 +4        QUIT

 +5       ;

BDGSPTR.m