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

ADGCEN31.m

Go to the documentation of this file.
  1. ADGCEN31 ; IHS/ADC/PDW/ENM - PRINT CENSUS AID-PATIENT LIST ; [ 03/25/1999 11:48 AM ]
  1. ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
  1. ;
  1. ;rtn prints listing of admissions, discharges, and transfers
  1. ;for each ward specified. Each ward on a separate page.
  1. ;Summary page at the end if all wards printed
  1. ;
  1. ;***> initialize variables
  1. S DGPAGE=0,Y=DGBDT X ^DD("DD") S DGDATE=Y,Y=DGEDT X ^DD("DD")
  1. S DGSITE=$P(^DIC(4,DUZ(2),0),U),DGDUZ=$P(^VA(200,DUZ,0),U,2)
  1. S DGX=0 F DGI="AA","TI","TO","AD","DT" S DGX=DGX+1,DGPOS(DGI)=DGX
  1. S DGDATE=DGDATE_" to "_Y,DGSTOP="",DGWW=0
  1. ;
  1. I DGWD="A" G INIT1 ;if all wards then loop
  1. E S DGWW=$P(^DIC(42,DGWD,0),U),^TMP($J,"WARD",DGWW)="" G INIT2
  1. INIT1 S DGWW=$O(^DIC(42,"B",DGWW)) G INIT2:DGWW=""
  1. S DGWW1=$O(^DIC(42,"B",DGWW,0)) ;get wards in alpha order
  1. I $D(^DIC(42,DGWW1,"I")),(^("I")="I") G INIT1 ;screen for inactives
  1. S ^TMP($J,"WARD",DGWW)="" G INIT1
  1. INIT2 ;
  1. ;
  1. ;***> find ward and print admissions
  1. S DGW=0
  1. WARD S DGW=$O(^TMP($J,"WARD",DGW)) G END:DGW="" S DGTOTL=0 D HEAD
  1. S DGX="AA",DGMOVE="ADMISSIONS",DGDT=0 D FIND G END1:DGSTOP=U
  1. ;
  1. ;***> print transfers in
  1. TRANSIN S DGX="TI",DGMOVE="WARD TRANSFERS IN",DGDT=0 D FIND G END1:DGSTOP=U
  1. ;
  1. ;***> print transfers out
  1. TRANSOUT S DGX="TO",DGMOVE="WARD TRANSFERS OUT",DGDT=0 D FIND G END1:DGSTOP=U
  1. ;
  1. ;***> print discharges
  1. DISCH S DGX="AD",DGMOVE="DISCHARGES",DGDT=0 D FIND G END1:DGSTOP=U
  1. ;
  1. ;***> print deaths
  1. DEATHS S DGX="DT",DGMOVE="DEATHS",DGDT=0 D FIND G END1:DGSTOP=U
  1. W !!?45,"CENSUS CHANGE FOR WARD: ",$J(DGTOTL,3)
  1. ;
  1. ;***> newborns
  1. NEWBORN I '$D(^TMP($J,"NEWA",DGW))&('$D(^TMP($J,"NEWD",DGW))) G NEXT
  1. S DGX="NEWA",DGDT=0,DGMOVE="NEWBORN ADMISSIONS" D FIND G END1:DGSTOP=U
  1. S DGX="NEWT",DGDT=0,DGMOVE="NEWBORN TRANSFER" D FIND G END1:DGSTOP=U
  1. S DGX="NEWD",DGDT=0,DGMOVE="NEWBORN DISCHARGES" D FIND G END1:DGSTOP=U
  1. S DGX=$P(DGCT("NEWBORN"),U)-$P(DGCT("NEWBORN"),U,3)-$P(DGCT("NEWBORN"),U,4)
  1. W !!?37,"NEWBORN CENSUS CHANGE FOR WARD: ",$J(DGX,3)
  1. ;
  1. NEXT I IOST["C-" K DIR S DIR(0)="E" D ^DIR S DGSTOP=X
  1. G WARD ;close loop, get next ward
  1. ;
  1. ;
  1. END G ^ADGCEN32 ;print summary page and end
  1. ;
  1. END1 G END1^ADGCEN32 ;quit
  1. ;
  1. ;
  1. ;***> find entries and print subrtn
  1. FIND I $Y>(IOSL-6) D NEWPG G F4:DGSTOP=U
  1. W !!?80-$L(DGMOVE)/2,DGMOVE S DGCOUNT=0
  1. F1 S DGDT=$O(^TMP($J,DGX,DGW,DGDT)) G F4:DGDT="" S DGNM=0
  1. F2 S DGNM=$O(^TMP($J,DGX,DGW,DGDT,DGNM)) G F1:DGNM="" S DFN=0
  1. F3 S DFN=$O(^TMP($J,DGX,DGW,DGDT,DGNM,DFN)) G F2:DFN=""
  1. ;
  1. S DGCHT=$P(^AUPNPAT(DFN,41,DUZ(2),0),U,2) ;chart number
  1. I $Y>(IOSL-4) D NEWPG G F4:DGSTOP=U
  1. S DGTM=$P(DGDT,".",2),DGTM=$S(DGTM="":"N/A",1:$E(DGTM_"000",1,4))
  1. W !?3,DGTM,?20,DGNM,?50,$J(DGCHT,6) S DGCOUNT=DGCOUNT+1 G F2
  1. ;
  1. F4 W !?60,"SUBTOTAL: ",$J(DGCOUNT,3)
  1. I DGX="AA"!(DGX="TI") D G F9
  1. .S DGTOTL=DGTOTL+DGCOUNT
  1. .S DGY=DGPOS(DGX),$P(DGCN(DGW),U,DGY)=DGCOUNT Q
  1. I DGX="NEWA" S $P(DGCT("NEWBORN"),U)=DGCOUNT G F9
  1. I DGX="NEWT" S $P(DGCT("NEWBORN"),U,3)=DGCOUNT G F9
  1. I DGX="NEWD" S $P(DGCT("NEWBORN"),U,4)=DGCOUNT G F9
  1. E S DGTOTL=DGTOTL-DGCOUNT,DGY=DGPOS(DGX),$P(DGCN(DGW),U,DGY)=DGCOUNT
  1. F9 Q ;leave subrtn
  1. ;
  1. NEWPG ;***> subrtn for end of page control
  1. I IOST'?1"C-".E D HEAD S DGSTOP="" Q
  1. K DIR S DIR(0)="E" D ^DIR S DGSTOP=X
  1. I DGSTOP'=U D HEAD
  1. Q
  1. ;
  1. I (IOST["C-")!(DGPAGE>0) W @IOF
  1. S DGLIN="",$P(DGLIN,"=",80)="" W !,DGLIN S DGPAGE=DGPAGE+1
  1. W !?11,"*****Confidential Patient Data Covered by Privacy Act*****"
  1. W !,DGDUZ,?80-$L(DGSITE)/2,DGSITE S DGTY="WARD CENSUS LISTING"
  1. W ! D TIME^ADGUTIL W ?80-$L(DGTY)/2,DGTY,?70,"Page: ",DGPAGE
  1. S Y=DT X ^DD("DD") W !,Y
  1. S DGWARD="*** "_DGW_" ***" W ?80-$L(DGWARD)/2,DGWARD
  1. W !?80-$L(DGDATE)/2,DGDATE,!,DGLIN
  1. I DGW'="SUMMARY" W !?3," Time",?20,"Patient Name",?50,"Chart #" G HD1
  1. W !,"Ward",?15,"Beg Census Admits Net Transfers Discharges Ending Census"
  1. HD1 S DGLIN="",$P(DGLIN,"-",80)="" W !,DGLIN
  1. Q