- 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
