BDGCEN1 ; IHS/ANMC/LJF - CENSUS AID-LIST BY WARD & TX ; [ 08/20/2004 11:40 AM ]
;;5.3;PIMS;**1001**;APR 26, 2002
;
NEW BDGWD,BDGED,BDGBD,BDGTX,BDGAGE
S BDGWD=+$$READ^BDGF("PO^9009016.2:EQMZ","Select Ward") Q:BDGWD<1
S BDGTX=$$READ^BDGF("S^A:ALL TREATING SPECIALTIES;O:ONE SPECIALTY ONLY","Choose Report Format") Q:BDGTX=U
I BDGTX="O" D Q:BDGTX<1 Q:BDGAGE=U
. S BDGTX=+$$READ^BDGF("PO^45.7:EMQZ","Within Ward, List Which Treating Specialty") Q:BDGTX<1
. S BDGAGE=$$READ^BDGF("S^A:ADULT;P:PEDIATRIC","Adult or Pediatric Census","","^D AGE^BDGCEN1")
;
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^BDGCEN1","CENSUS AID2","BDGWD;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 AID2
;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 AID2")
D CLEAR^VALM1
Q
;
HDR ; -- header code
NEW X,Y,Z
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)
S Y=$S(BDGTX="A":"All Treating Specialties",1:$$GET1^DIQ(45.7,BDGTX,.01))
S Z=$S('$D(BDGAGE):"",BDGAGE="A":"(Adult)",1:"(Pediatric)")
S X=X_" - "_Y_" "_Z,VALMHDR(2)=$$SP(79-$L(X)\2)_X
Q
;
INIT ; -- init variables and list array
NEW X,RTN
K ^TMP("BDGCEN1",$J),^TMP("BDGCEN10",$J)
S RTN=$S(BDGTX="A":"^BDGCEN11",1:"^BDGCEN10")
D GUIR^XBLM(RTN,"^TMP(""BDGCEN10"",$J,")
S (X,VALMCNT)=0
F S X=$O(^TMP("BDGCEN10",$J,X)) Q:'X D
. S VALMCNT=VALMCNT+1
. S ^TMP("BDGCEN1",$J,VALMCNT,0)=^TMP("BDGCEN10",$J,X)
K ^TMP("BDGCEN10",$J)
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("BDGCEN1",$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^BDGCEN10
;
S X=0 F S X=$O(^TMP("BDGCEN1",$J,X)) Q:'X D
. I $Y>(IOSL-4) D HEAD^BDGCEN10
. W !,^TMP("BDGCEN1",$J,X,0)
;
D EXIT,^%ZISC
Q
BDGCEN1 ; IHS/ANMC/LJF - CENSUS AID-LIST BY WARD & TX ; [ 08/20/2004 11:40 AM ]
+1 ;;5.3;PIMS;**1001**;APR 26, 2002
+2 ;
+3 NEW BDGWD,BDGED,BDGBD,BDGTX,BDGAGE
+4 SET BDGWD=+$$READ^BDGF("PO^9009016.2:EQMZ","Select Ward")
IF BDGWD<1
QUIT
+5 SET BDGTX=$$READ^BDGF("S^A:ALL TREATING SPECIALTIES;O:ONE SPECIALTY ONLY","Choose Report Format")
IF BDGTX=U
QUIT
+6 IF BDGTX="O"
Begin DoDot:1
+7 SET BDGTX=+$$READ^BDGF("PO^45.7:EMQZ","Within Ward, List Which Treating Specialty")
IF BDGTX<1
QUIT
+8 SET BDGAGE=$$READ^BDGF("S^A:ADULT;P:PEDIATRIC","Adult or Pediatric Census","","^D AGE^BDGCEN1")
End DoDot:1
IF BDGTX<1
QUIT
IF BDGAGE=U
QUIT
+9 ;
+10 SET BDGBD=$$READ^BDGF("DO^::EX","Select beginning date")
IF BDGBD<1
QUIT
+11 SET BDGED=$$READ^BDGF("DO^::EX","Select ending date")
IF BDGED<1
QUIT
+12 ;
+13 IF $$BROWSE^BDGF="B"
DO EN
QUIT
+14 DO ZIS^BDGF("QP","EN^BDGCEN1","CENSUS AID2","BDGWD;BDGTX;BDGBD;BDGED;BDGAGE")
+15 DO HOME^%ZIS
+16 QUIT
+17 ;
+18 ;
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 AID2
+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 AID2")
+9 DO CLEAR^VALM1
+10 QUIT
+11 ;
HDR ; -- header code
+1 NEW X,Y,Z
+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(42,BDGWD,.01)
+5 SET Y=$SELECT(BDGTX="A":"All Treating Specialties",1:$$GET1^DIQ(45.7,BDGTX,.01))
+6 SET Z=$SELECT('$DATA(BDGAGE):"",BDGAGE="A":"(Adult)",1:"(Pediatric)")
+7 SET X=X_" - "_Y_" "_Z
SET VALMHDR(2)=$$SP(79-$LENGTH(X)\2)_X
+8 QUIT
+9 ;
INIT ; -- init variables and list array
+1 NEW X,RTN
+2 KILL ^TMP("BDGCEN1",$JOB),^TMP("BDGCEN10",$JOB)
+3 SET RTN=$SELECT(BDGTX="A":"^BDGCEN11",1:"^BDGCEN10")
+4 DO GUIR^XBLM(RTN,"^TMP(""BDGCEN10"",$J,")
+5 SET (X,VALMCNT)=0
+6 FOR
SET X=$ORDER(^TMP("BDGCEN10",$JOB,X))
IF 'X
QUIT
Begin DoDot:1
+7 SET VALMCNT=VALMCNT+1
+8 SET ^TMP("BDGCEN1",$JOB,VALMCNT,0)=^TMP("BDGCEN10",$JOB,X)
End DoDot:1
+9 KILL ^TMP("BDGCEN10",$JOB)
+10 QUIT
+11 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP("BDGCEN1",$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^BDGCEN10
+5 ;
+6 SET X=0
FOR
SET X=$ORDER(^TMP("BDGCEN1",$JOB,X))
IF 'X
QUIT
Begin DoDot:1
+7 IF $Y>(IOSL-4)
DO HEAD^BDGCEN10
+8 WRITE !,^TMP("BDGCEN1",$JOB,X,0)
End DoDot:1
+9 ;
+10 DO EXIT
DO ^%ZISC
+11 QUIT
