Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BDGCEN1

BDGCEN1.m

Go to the documentation of this file. 
  1. BDGCEN1 ; IHS/ANMC/LJF - CENSUS AID-LIST BY WARD & TX ;  [ 08/20/2004  11:40 AM ]
  1.  ;;5.3;PIMS;**1001**;APR 26, 2002
  1.  ;
  1.  NEW BDGWD,BDGED,BDGBD,BDGTX,BDGAGE
  1.  S BDGWD=+$$READ^BDGF("PO^9009016.2:EQMZ","Select Ward") Q:BDGWD<1
  1.  S BDGTX=$$READ^BDGF("S^A:ALL TREATING SPECIALTIES;O:ONE SPECIALTY ONLY","Choose Report Format") Q:BDGTX=U
  1.  I BDGTX="O" D  Q:BDGTX<1  Q:BDGAGE=U
  1.  . S BDGTX=+$$READ^BDGF("PO^45.7:EMQZ","Within Ward, List Which Treating Specialty") Q:BDGTX<1
  1.  . S BDGAGE=$$READ^BDGF("S^A:ADULT;P:PEDIATRIC","Adult or Pediatric Census","","^D AGE^BDGCEN1")
  1.  ;
  1.  S BDGBD=$$READ^BDGF("DO^::EX","Select beginning date") Q:BDGBD<1
  1.  S BDGED=$$READ^BDGF("DO^::EX","Select ending date") Q:BDGED<1
  1.  ;
  1.  I $$BROWSE^BDGF="B" D EN Q
  1.  D ZIS^BDGF("QP","EN^BDGCEN1","CENSUS AID2","BDGWD;BDGTX;BDGBD;BDGED;BDGAGE")
  1.  D HOME^%ZIS
  1.  Q
  1.  ;
  1.  ;
  1. AGE ;EP; help for Adult vs. Peds question
  1.  D MSG^BDGF("This report displays either adult census figures",2,0)
  1.  D MSG^BDGF("or pediatric ones.  Please choose one; A or P.",1,1)
  1.  Q
  1.  ;
  1.  ;
  1. EN ;EP; -- main entry point for BDG CENSUS AID2
  1.  ;IHS/ITSC/WAR 11/13/03 added New 'BDGION' variable and S BDGION=ION
  1.  ;    to remedy queing problem with printer. See line tag PRINT
  1.  NEW VALMCNT,BDGION
  1.  ;I $E(IOST,1,2)="P-" D INIT,PRINT Q
  1.  ;I $E(IOST,1,2)="P-" S BDGION=IOP D INIT,PRINT Q
  1.  I $E(IOST,1,2)="P-" S BDGION=ION D INIT,PRINT Q  ;IHS/ITSC/LJF 7/8/2004 PATCH #1001
  1.  D TERM^VALM0,CLEAR^VALM1
  1.  D EN^VALM("BDG CENSUS AID2")
  1.  D CLEAR^VALM1
  1.  Q
  1.  ;
  1. HDR ; -- header code
  1.  NEW X,Y,Z
  1.  S X=$$FMTE^XLFDT(BDGBD)_" to "_$$FMTE^XLFDT(BDGED)
  1.  S VALMHDR(1)=$$SP(75-$L(X)\2)_X
  1.  S X=$$GET1^DIQ(42,BDGWD,.01)
  1.  S Y=$S(BDGTX="A":"All Treating Specialties",1:$$GET1^DIQ(45.7,BDGTX,.01))
  1.  S Z=$S('$D(BDGAGE):"",BDGAGE="A":"(Adult)",1:"(Pediatric)")
  1.  S X=X_" - "_Y_" "_Z,VALMHDR(2)=$$SP(79-$L(X)\2)_X
  1.  Q
  1.  ;
  1. INIT ; -- init variables and list array
  1.  NEW X,RTN
  1.  K ^TMP("BDGCEN1",$J),^TMP("BDGCEN10",$J)
  1.  S RTN=$S(BDGTX="A":"^BDGCEN11",1:"^BDGCEN10")
  1.  D GUIR^XBLM(RTN,"^TMP(""BDGCEN10"",$J,")
  1.  S (X,VALMCNT)=0
  1.  F  S X=$O(^TMP("BDGCEN10",$J,X)) Q:'X  D
  1.  . S VALMCNT=VALMCNT+1
  1.  . S ^TMP("BDGCEN1",$J,VALMCNT,0)=^TMP("BDGCEN10",$J,X)
  1.  K ^TMP("BDGCEN10",$J)
  1.  Q
  1.  ;
  1. HELP ; -- help code
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1. EXIT ; -- exit code
  1.  K ^TMP("BDGCEN1",$J)
  1.  Q
  1.  ;
  1. EXPND ; -- expand code
  1.  Q
  1.  ;
  1. PAD(D,L) ;EP -- SUBRTN to pad length of data
  1.  ; -- D=data L=length
  1.  Q $E(D_$$REPEAT^XLFSTR(" ",L),1,L)
  1.  ;
  1. SP(N) ; -- SUBRTN to pad N number of spaces
  1.  Q $$PAD(" ",N)
  1.  ;
  1. PRINT ; print report to paper
  1.  NEW X,DGPAGE
  1.  ;IHS/ITSC/WAR 11/13/03 added next line - queing was not working
  1.  S IOP=BDGION D ^%ZIS
  1.  U IO S DGPAGE=0 D HEAD^BDGCEN10
  1.  ;
  1.  S X=0 F  S X=$O(^TMP("BDGCEN1",$J,X)) Q:'X  D
  1.  . I $Y>(IOSL-4) D HEAD^BDGCEN10
  1.  . W !,^TMP("BDGCEN1",$J,X,0)
  1.  ;
  1.  D EXIT,^%ZISC
  1.  Q