BDGCEN.m

BDGCEN ; IHS/ANMC/LJF - CENSUS AID-LIST BY WARD ONLY ;  [ 08/20/2004  11:40 AM ]

 ;;5.3;PIMS;**1001**;APR 26, 2002

 ;

 NEW BDGWD,BDGED,BDGBD

 S BEGIN=$$GET1^DIQ(43,1,10,"I")   ;earliest G&L date

 S BEGIN=$$FMADD^XLFDT(BEGIN,-1)   ;initialize date

 S BDGWD=+$$READ^BDGF("PO^9009016.2:EQMZ","Select Ward") Q:BDGWD<1

 S BDGBD=$$READ^BDGF("DO^"_BEGIN_":"_DT_":EX","Select beginning date")

 Q:BDGBD<1

 S BDGED=$$READ^BDGF("DO^"_BEGIN_":"_DT_":EX","Select ending date")

 Q:BDGED<1

 ;

 I $$BROWSE^BDGF="B" D EN Q

 D ZIS^BDGF("QP","EN^BDGCEN","CENSUS AID1","BDGWD;BDGBD;BDGED")

 D HOME^%ZIS

 Q

 ;

EN ;EP; -- main entry point for BDG CENSUS AID1

 ;IHS/ITSC/WAR 11/13/03 added New 'BDGION' variable and S BDGION=ION

 ;    to remedy queing problem with printer. See line tag PRINT

 NEW VALMCNT,BDGION

 ;I $E(IOST,1,2)="P-" D INIT,PRINT Q

 ;I $E(IOST,1,2)="P-" S BDGION=IOP D INIT,PRINT Q

 I $E(IOST,1,2)="P-" S BDGION=ION D INIT,PRINT Q  ;IHS/ITSC/LJF 7/8/2004 PATCH #1001

 D TERM^VALM0,CLEAR^VALM1

 D EN^VALM("BDG CENSUS AID1")

 D CLEAR^VALM1

 Q

 ;

HDR ; -- header code

 NEW X

 S X=$$FMTE^XLFDT(BDGBD)_" to "_$$FMTE^XLFDT(BDGED)

 S VALMHDR(1)=$$SP(75-$L(X)\2)_X

 S X=$$GET1^DIQ(42,BDGWD,.01)          ;ward name

 S VALMHDR(2)=$$SP(75-$L(X)\2)_X

 Q

 ;

INIT ; -- init variables and list array

 NEW X

 K ^TMP("BDGCEN",$J),^TMP("BDGCEN0",$J)

 D GUIR^XBLM("^BDGCEN0","^TMP(""BDGCEN0"",$J,")

 S (X,VALMCNT)=0

 F  S X=$O(^TMP("BDGCEN0",$J,X)) Q:'X  D

 . S VALMCNT=VALMCNT+1

 . S ^TMP("BDGCEN",$J,VALMCNT,0)=^TMP("BDGCEN0",$J,X)

 K ^TMP("BDGCEN0",$J)

 Q

 ;

HELP ; -- help code

 S X="?" D DISP^XQORM1 W !!

 Q

 ;

EXIT ; -- exit code

 K ^TMP("BDGCEN",$J)

 Q

 ;

EXPND ; -- expand code

 Q

 ;

PAD(D,L) ;EP -- SUBRTN to pad length of data

 ; -- D=data L=length

 Q $E(D_$$REPEAT^XLFSTR(" ",L),1,L)

 ;

SP(N) ; -- SUBRTN to pad N number of spaces

 Q $$PAD(" ",N)

 ;

PRINT ; print report to paper

 NEW X,DGPAGE

 ;IHS/ITSC/WAR 11/13/03 added next line - queing was not working

 S IOP=BDGION D ^%ZIS

 U IO S DGPAGE=0 D HEAD^BDGCEN0

 ;

 S X=0 F  S X=$O(^TMP("BDGCEN",$J,X)) Q:'X  D

 . I $Y>(IOSL-4) D HEAD^BDGCEN0

 . W !,^TMP("BDGCEN",$J,X,0)

 ;

 D EXIT,^%ZISC

 Q

BDGCEN    ; IHS/ANMC/LJF - CENSUS AID-LIST BY WARD ONLY ;  [ 08/20/2004  11:40 AM ]

 +1       ;;5.3;PIMS;**1001**;APR 26, 2002

 +2       ;

 +3        NEW BDGWD,BDGED,BDGBD

 +4       ;earliest G&L date

           SET BEGIN=$$GET1^DIQ(43,1,10,"I")

 +5       ;initialize date

           SET BEGIN=$$FMADD^XLFDT(BEGIN,-1)

 +6        SET BDGWD=+$$READ^BDGF("PO^9009016.2:EQMZ","Select Ward")

           IF BDGWD<1

               QUIT 

 +7        SET BDGBD=$$READ^BDGF("DO^"_BEGIN_":"_DT_":EX","Select beginning date")

 +8        IF BDGBD<1

               QUIT 

 +9        SET BDGED=$$READ^BDGF("DO^"_BEGIN_":"_DT_":EX","Select ending date")

 +10       IF BDGED<1

               QUIT 

 +11      ;

 +12       IF $$BROWSE^BDGF="B"

               DO EN

               QUIT 

 +13       DO ZIS^BDGF("QP","EN^BDGCEN","CENSUS AID1","BDGWD;BDGBD;BDGED")

 +14       DO HOME^%ZIS

 +15       QUIT 

 +16      ;

EN        ;EP; -- main entry point for BDG CENSUS AID1

 +1       ;IHS/ITSC/WAR 11/13/03 added New 'BDGION' variable and S BDGION=ION

 +2       ;    to remedy queing problem with printer. See line tag PRINT

 +3        NEW VALMCNT,BDGION

 +4       ;I $E(IOST,1,2)="P-" D INIT,PRINT Q

 +5       ;I $E(IOST,1,2)="P-" S BDGION=IOP D INIT,PRINT Q

 +6       ;IHS/ITSC/LJF 7/8/2004 PATCH #1001

           IF $EXTRACT(IOST,1,2)="P-"

               SET BDGION=ION

               DO INIT

               DO PRINT

               QUIT 

 +7        DO TERM^VALM0

           DO CLEAR^VALM1

 +8        DO EN^VALM("BDG CENSUS AID1")

 +9        DO CLEAR^VALM1

 +10       QUIT 

 +11      ;

HDR       ; -- header code

 +1        NEW X

 +2        SET X=$$FMTE^XLFDT(BDGBD)_" to "_$$FMTE^XLFDT(BDGED)

 +3        SET VALMHDR(1)=$$SP(75-$LENGTH(X)\2)_X

 +4       ;ward name

           SET X=$$GET1^DIQ(42,BDGWD,.01)

 +5        SET VALMHDR(2)=$$SP(75-$LENGTH(X)\2)_X

 +6        QUIT 

 +7       ;

INIT      ; -- init variables and list array

 +1        NEW X

 +2        KILL ^TMP("BDGCEN",$JOB),^TMP("BDGCEN0",$JOB)

 +3        DO GUIR^XBLM("^BDGCEN0","^TMP(""BDGCEN0"",$J,")

 +4        SET (X,VALMCNT)=0

 +5        FOR 

               SET X=$ORDER(^TMP("BDGCEN0",$JOB,X))

               IF 'X

                   QUIT 

               Begin DoDot:1

 +6                SET VALMCNT=VALMCNT+1

 +7                SET ^TMP("BDGCEN",$JOB,VALMCNT,0)=^TMP("BDGCEN0",$JOB,X)

               End DoDot:1

 +8        KILL ^TMP("BDGCEN0",$JOB)

 +9        QUIT 

 +10      ;

HELP      ; -- help code

 +1        SET X="?"

           DO DISP^XQORM1

           WRITE !!

 +2        QUIT 

 +3       ;

EXIT      ; -- exit code

 +1        KILL ^TMP("BDGCEN",$JOB)

 +2        QUIT 

 +3       ;

EXPND     ; -- expand code

 +1        QUIT 

 +2       ;

PAD(D,L)  ;EP -- SUBRTN to pad length of data

 +1       ; -- D=data L=length

 +2        QUIT $EXTRACT(D_$$REPEAT^XLFSTR(" ",L),1,L)

 +3       ;

SP(N)     ; -- SUBRTN to pad N number of spaces

 +1        QUIT $$PAD(" ",N)

 +2       ;

PRINT     ; print report to paper

 +1        NEW X,DGPAGE

 +2       ;IHS/ITSC/WAR 11/13/03 added next line - queing was not working

 +3        SET IOP=BDGION

           DO ^%ZIS

 +4        USE IO

           SET DGPAGE=0

           DO HEAD^BDGCEN0

 +5       ;

 +6        SET X=0

           FOR 

               SET X=$ORDER(^TMP("BDGCEN",$JOB,X))

               IF 'X

                   QUIT 

               Begin DoDot:1

 +7                IF $Y>(IOSL-4)

                       DO HEAD^BDGCEN0

 +8                WRITE !,^TMP("BDGCEN",$JOB,X,0)

               End DoDot:1

 +9       ;

 +10       DO EXIT

           DO ^%ZISC

 +11       QUIT