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

AQAQPR12.m

Go to the documentation of this file. 
  1. AQAQPR12 ;IHS/ANMC/LJF - ADMISSIONS BY PROVIDER; [ 08/06/92  4:29 PM ]
  1.  ;;2.2;STAFF CREDENTIALS;;01 OCT 1992
  1.  ;
  1.  ;>>> initialize variables <<<
  1.  S AQAQPAGE=0,AQAQSTOP="",AQAQDUZ=$P(^DIC(3,DUZ,0),U,2)
  1.  S AQAQSITE=$P(^DIC(4,DUZ(2),0),U)    ;set site
  1.  S AQAQRG=$E(AQAQBDT,4,5)_"/"_$E(AQAQBDT,6,7)_"/"_$E(AQAQBDT,2,3)_" to "
  1.  S AQAQRG=AQAQRG_$E(AQAQEDT,4,5)_"/"_$E(AQAQEDT,6,7)_"/"_$E(AQAQEDT,2,3)
  1.  S AQAQLINE="",$P(AQAQLINE,"=",80)=""
  1.  S AQAQLIN2="",$P(AQAQLIN2,"-",80)=""
  1.  S (AQAQICNT,AQAQSCNT,AQAQWCNT,AQAQTCNT,AQAQTICT,AQAQTWCT)=0
  1.  ;
  1.  I '$D(^UTILITY("AQAQPR1",$J)) D HEAD W !!,">>> NO DATA FOR DATES",!! G WAIT
  1.  ;
  1.  ;>>> pull data by provider, then print <<<
  1.  S AQAQPRV=0
  1.  F  S AQAQPRV=$O(^UTILITY("AQAQPR1",$J,AQAQPRV)) Q:AQAQPRV=""  Q:AQAQSTOP=U  D
  1.  .I (AQAQSCNT>0)!(AQAQICNT>0) D COUNT
  1.  .I AQAQPAGE=0 D HEAD
  1.  .E  D NEWPG Q:AQAQSTOP=U
  1.  .W !!?80-$L(AQAQPRV)/2,AQAQPRV,!  ;print provider subheading
  1.  .S (AQAQDT,AQAQLST)=0
  1.  .F  S AQAQDT=$O(^UTILITY("AQAQPR1",$J,AQAQPRV,AQAQDT)) Q:AQAQDT=""  Q:AQAQSTOP=U  D
  1.  ..I $E(AQAQLST,4,5)'=$E(AQAQDT)&(AQAQLST'=0) D COUNT  ;if new month, get subcounts
  1.  ..S DFN=0
  1.  ..F  S DFN=$O(^UTILITY("AQAQPR1",$J,AQAQPRV,AQAQDT,DFN)) Q:DFN=""  Q:AQAQSTOP=U  D
  1.  ...S AQAQSTR=^(DFN) D LINE  ;print line with admission data
  1.  ;
  1.  ;>>> do last month subcount, then print totals <<<
  1.  G END:AQAQSTOP=U
  1.  I (AQAQSCNT>0)!(AQAQICNT>0)!(AQAQWCNT>0) D COUNT
  1.  D NEWPG W !!,"        ADMISSIONS: ",AQAQTCNT
  1.  W !,"    ICU ADMISSIONS: ",AQAQTICT
  1.  W !,"  TOTAL ADMISSIONS: ",AQAQTCNT+AQAQTICT
  1.  W !,"NEWBORN ADMISSIONS: ",AQAQTWCT
  1.  W !,AQAQLINE
  1. WAIT I IOST["C-" W ! K DIR S DIR(0)="E",DIR("A")="RETURN to continue" D ^DIR
  1.  ;
  1.  ;
  1. END ;EP;>>> eoj <<<
  1.  W @IOF D ^%ZISC D KILL^AQAQUTIL K ^UTILITY("AQAQPR1",$J) Q
  1.  ;
  1.  ;>>> END OF MAIN ROUTINE <<<
  1.  ;
  1.  ;
  1. NEWPG ;***> SUBRTN for end of page control
  1.  I IOST'?1"C-".E D HEAD S AQAQSTOP="" Q
  1.  I AQAQPAGE>0 K DIR S DIR(0)="E" D ^DIR S AQAQSTOP=X
  1.  I AQAQSTOP'=U D HEAD
  1.  Q
  1.  ;
  1.  I (IOST["C-")!(AQAQPAGE>0) W @IOF
  1.  W !,AQAQLINE S AQAQPAGE=AQAQPAGE+1
  1.  W !?11,"*****Confidential Patient Data Covered by Privacy Act*****"
  1.  W !,AQAQDUZ,?80-$L(AQAQSITE)/2,AQAQSITE
  1.  S AQAQTY="ADMISSIONS BY PROVIDER"
  1.  W ! D ^%T W ?80-$L(AQAQTY)/2,AQAQTY,?70,"Page: ",AQAQPAGE
  1.  S Y=DT X ^DD("DD") W !,Y,?30,AQAQRG  ;date range
  1.  W !,AQAQLINE
  1.  W !,"Admit Date",?20,"Patient",?43,"Ward",?48,"Srv",?55,"Admitting DX"
  1.  W !,AQAQLIN2
  1.  Q
  1.  ;
  1. LINE ;***> SUBRTN to print line of data and increment counts
  1.  S Y=AQAQDT X ^DD("DD") W !,Y    ;admit date/time
  1.  W ?20,$E($P(AQAQSTR,U),1,20)  ;patient name
  1.  W ?43,$E($P(AQAQSTR,U,2),1,3),?48,$E($P(AQAQSTR,U,3),1,3)  ;ward & srv
  1.  W ?55,$E($P(AQAQSTR,U,4),1,23)  ;admitting dx
  1.  I $P(AQAQSTR,U,5)=1 S AQAQICNT=AQAQICNT+1  ;increment icu count
  1.  E  I $P(AQAQSTR,U,3)="NEWBORN" S AQAQWCNT=AQAQWCNT+1  ;newborn count
  1.  E  S AQAQSCNT=AQAQSCNT+1   ;increment subcount
  1.  I $Y>(IOSL-5) D NEWPG
  1.  Q
  1.  ;
  1. COUNT ;***> SUBRTN to print subcounts and increment totals
  1.  W !,"        Admissions: ",AQAQSCNT S AQAQTCNT=AQAQTCNT+AQAQSCNT
  1.  W !,"    ICU Admissions: ",AQAQICNT S AQAQTICT=AQAQTICT+AQAQICNT
  1.  W !,"  Total Admissions: ",AQAQICNT+AQAQSCNT
  1.  W !,"Newborn Admissions: ",AQAQWCNT S AQAQTWCT=AQAQTWCT+AQAQWCNT
  1.  W !,AQAQLINE S (AQAQSCNT,AQAQICNT,AQAQWCNT)=0
  1.  Q