BDGCEN2 ; IHS/ANMC/LJF - CENSUS AID-LIST BY SERVICE ; [ 12/18/2003 1:40 PM ]
;;5.3;PIMS;;APR 26, 2002
;
NEW BDGED,BDGBD,BDGTX,BDGAGE
S BDGTX=+$$READ^BDGF("PO^45.7:EMQZ","Select Treating Specialty") Q:BDGTX<1
;
S BDGAGE=$$READ^BDGF("S^A:ADULT;P:PEDIATRIC","Adult or Pediatric Census","","^D AGE^BDGCEN2") Q:BDGAGE="" Q:BDGAGE=U
;
S BDGBD=$$READ^BDGF("DO^::EX","Select beginning date") Q:BDGBD<1
S BDGED=$$READ^BDGF("DO^::EX","Select ending date") Q:BDGED<1
;
I $$BROWSE^BDGF="B" D EN Q
D ZIS^BDGF("QP","EN^BDGCEN2","CENSUS AID3","BDGTX;BDGBD;BDGED;BDGAGE")
D HOME^%ZIS
Q
;
;
AGE ;EP; help for Adult vs. Peds question
D MSG^BDGF("This report displays either adult census figures",2,0)
D MSG^BDGF("or pediatric ones. Please choose one; A or P.",1,1)
Q
;
;
EN ;EP; -- main entry point for BDG CENSUS AID3
;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=ION D INIT,PRINT Q
D TERM^VALM0,CLEAR^VALM1
D EN^VALM("BDG CENSUS AID3")
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(45.7,BDGTX,.01)_" ("_$S(BDGAGE="A":"Adult",1:"Pediatric")_")"
S VALMHDR(2)=$$SP(75-$L(X)\2)_X
Q
;
INIT ; -- init variables and list array
NEW X
K ^TMP("BDGCEN2",$J),^TMP("BDGCEN20",$J)
D GUIR^XBLM("^BDGCEN20","^TMP(""BDGCEN20"",$J,")
S (X,VALMCNT)=0
F S X=$O(^TMP("BDGCEN20",$J,X)) Q:'X D
. ;IHS/ITSC/WAR 11/13/03 problem with ^TMP("BDGCEN20" added 'IF'
. ; statement and second DO dot
. I +$G(^TMP("BDGCEN20",$J,X))'=0 D
.. S VALMCNT=VALMCNT+1
.. S ^TMP("BDGCEN2",$J,VALMCNT,0)=^TMP("BDGCEN20",$J,X)
K ^TMP("BDGCEN20",$J)
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("BDGCEN2",$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^BDGCEN20
;
S X=0 F S X=$O(^TMP("BDGCEN2",$J,X)) Q:'X D
. I $Y>(IOSL-4) D HEAD^BDGCEN20
. W !,^TMP("BDGCEN2",$J,X,0)
;
D EXIT,^%ZISC
Q
BDGCEN2 ; IHS/ANMC/LJF - CENSUS AID-LIST BY SERVICE ; [ 12/18/2003 1:40 PM ]
+1 ;;5.3;PIMS;;APR 26, 2002
+2 ;
+3 NEW BDGED,BDGBD,BDGTX,BDGAGE
+4 SET BDGTX=+$$READ^BDGF("PO^45.7:EMQZ","Select Treating Specialty")
IF BDGTX<1
QUIT
+5 ;
+6 SET BDGAGE=$$READ^BDGF("S^A:ADULT;P:PEDIATRIC","Adult or Pediatric Census","","^D AGE^BDGCEN2")
IF BDGAGE=""
QUIT
IF BDGAGE=U
QUIT
+7 ;
+8 SET BDGBD=$$READ^BDGF("DO^::EX","Select beginning date")
IF BDGBD<1
QUIT
+9 SET BDGED=$$READ^BDGF("DO^::EX","Select ending date")
IF BDGED<1
QUIT
+10 ;
+11 IF $$BROWSE^BDGF="B"
DO EN
QUIT
+12 DO ZIS^BDGF("QP","EN^BDGCEN2","CENSUS AID3","BDGTX;BDGBD;BDGED;BDGAGE")
+13 DO HOME^%ZIS
+14 QUIT
+15 ;
+16 ;
AGE ;EP; help for Adult vs. Peds question
+1 DO MSG^BDGF("This report displays either adult census figures",2,0)
+2 DO MSG^BDGF("or pediatric ones. Please choose one; A or P.",1,1)
+3 QUIT
+4 ;
+5 ;
EN ;EP; -- main entry point for BDG CENSUS AID3
+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 IF $EXTRACT(IOST,1,2)="P-"
SET BDGION=ION
DO INIT
DO PRINT
QUIT
+6 DO TERM^VALM0
DO CLEAR^VALM1
+7 DO EN^VALM("BDG CENSUS AID3")
+8 DO CLEAR^VALM1
+9 QUIT
+10 ;
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 SET X=$$GET1^DIQ(45.7,BDGTX,.01)_" ("_$SELECT(BDGAGE="A":"Adult",1:"Pediatric")_")"
+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("BDGCEN2",$JOB),^TMP("BDGCEN20",$JOB)
+3 DO GUIR^XBLM("^BDGCEN20","^TMP(""BDGCEN20"",$J,")
+4 SET (X,VALMCNT)=0
+5 FOR
SET X=$ORDER(^TMP("BDGCEN20",$JOB,X))
IF 'X
QUIT
Begin DoDot:1
+6 ;IHS/ITSC/WAR 11/13/03 problem with ^TMP("BDGCEN20" added 'IF'
+7 ; statement and second DO dot
+8 IF +$GET(^TMP("BDGCEN20",$JOB,X))'=0
Begin DoDot:2
+9 SET VALMCNT=VALMCNT+1
+10 SET ^TMP("BDGCEN2",$JOB,VALMCNT,0)=^TMP("BDGCEN20",$JOB,X)
End DoDot:2
End DoDot:1
+11 KILL ^TMP("BDGCEN20",$JOB)
+12 QUIT
+13 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP("BDGCEN2",$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^BDGCEN20
+5 ;
+6 SET X=0
FOR
SET X=$ORDER(^TMP("BDGCEN2",$JOB,X))
IF 'X
QUIT
Begin DoDot:1
+7 IF $Y>(IOSL-4)
DO HEAD^BDGCEN20
+8 WRITE !,^TMP("BDGCEN2",$JOB,X,0)
End DoDot:1
+9 ;
+10 DO EXIT
DO ^%ZISC
+11 QUIT
