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

ADGICUT.m

Go to the documentation of this file. 
  1. ADGICUT ; IHS/ADC/PDW/ENM - PRINT TRANSFERS TO ICU ; [ 03/25/1999  11:48 AM ]
  1.  ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
  1.  ;
  1.  W @IOF,!!?20,"TRANSFERS TO ICU REPORT",!!
  1.  ;***> get date range
  1. BDATE S %DT="AEQ",%DT("A")="Select beginning date: ",X="" D ^%DT
  1.  G END:Y=-1 S DGBDT=Y
  1. EDATE S %DT="AEQ",%DT("A")="Select ending date: ",X="" D ^%DT
  1.  G END:Y=-1 S DGEDT=Y
  1.  ;
  1.  ;***> get print device
  1.  S %ZIS="PQ" D ^%ZIS G END:POP,QUE:$D(IO("Q")) U IO G INIT
  1. QUE K IO("Q") S ZTRTN="INIT^ADGICUT",ZTDESC="INPATIENT STATS"
  1.  S ZTSAVE("DGBDT")="",ZTSAVE("DGEDT")=""
  1.  D ^%ZTLOAD D ^%ZISC K ZTSK
  1. END K Y,DGBDT,DGEDT D HOME^%ZIS Q
  1.  ;
  1. INIT ;***> initialize variables
  1.  S DGDUZ=$P(^VA(200,DUZ,0),U,2),DGFAC=$P(^DIC(4,DUZ(2),0),U),DGPAGE=0
  1.  S DGLINE="",$P(DGLINE,"=",81)="",DGLIN1="",$P(DGLIN1,"-",81)=""
  1.  S DGSTOP=""
  1.  ;
  1.  ;***> find ICU wards for facility
  1.  S DGX=0 K DGICU
  1. ICU S DGX=$O(^DIC(42,DGX)) G DATES:DGX'=+DGX
  1.  I $D(^DIC(42,DGX,"I")),^("I")="I" G ICU  ;check for inactive wards
  1.  ;G ICU:$P(^DIC(42,DGX,"IHS"),U)=""  ;not an ICU ward;IHS/ORDC/LJF 3/3/93 changed code for new field definition
  1.  ;G ICU:$P(^DIC(42,DGX,"IHS"),U)'="I"  ;not an ICU ward;IHS/ORDC/LJF 3/9/93 not using PCU at this time
  1.  G ICU:$P(^DIC(42,DGX,"IHS"),U)'="Y"  ;not an ICU ward;IHS/ORDC/LJF 3/9/93 not using PCU at this time;IHS/ORDC/LJF 4/7/94 changed again 'causefield def overwritten
  1.  S DGICU(DGX)="" G ICU  ;set ICU dfn into array
  1.  ;
  1. DATES D HDR G NOICU:'$D(DGICU)  ;no ICU at your facility
  1.  ;***> loop thru transfer dates
  1.  S DGDT=DGBDT-.0001
  1.  F  S DGDT=$O(^DGPM("AMV2",DGDT)) Q:DGDT=""!(DGDT>(DGEDT_.2400))  D
  1.  . S DFN=0 Q:DGSTOP=U
  1.  . F  S DFN=$O(^DGPM("AMV2",DGDT,DFN)) Q:'DFN!(DGSTOP=U)  D
  1.  .. S DGTR=0
  1.  .. F  S DGTR=$O(^DGPM("AMV2",DGDT,DFN,DGTR)) Q:'DGTR!(DGSTOP=U)  D 2
  1. END1 ;***> eoj
  1.  I IOST?1"C-".E D PRTOPT^ADGVAR
  1.  W @IOF D KILL^ADGUTIL D ^%ZISC Q
  1.  Q
  1.  ;
  1. 2 Q:'$D(^DGPM(DGTR,0))  S DGX=^(0)  ;set transfer
  1.  Q:$P(DGX,U,6)=""  ;not an interward transfer
  1.  Q:'$D(DGICU($P(DGX,U,6)))  ;was transfer to an ICU?
  1.  S DGADM=$P(^DGPM(DGTR,0),U,14) Q:'DGADM
  1.  ;
  1.  ;***> print transfers
  1.  W !!,$E($P(^DPT(DFN,0),U),1,18)   ;print patient name
  1.  W ?20,$J($P(^AUPNPAT(DFN,41,DUZ(2),0),U,2),6)  ;print chart #
  1.  S DGY=^DGPM(DGADM,0)  ;set admission node variable
  1.  S DGAD=$P($P(DGY,U),"."),DGTM=$P($P(DGY,U),".",2)_"000"  ;adm dat/tim
  1.  W ?30,$E(DGAD,4,5)_"/"_$E(DGAD,6,7)_"/"_$E(DGAD,2,3)_"@"_$E(DGTM,1,4)
  1.  S DGTD=$P(DGDT,"."),DGTM=$P(DGDT,".",2)_"000"  ;trans date/time
  1.  W ?45,$E(DGTD,4,5)_"/"_$E(DGTD,6,7)_"/"_$E(DGTD,2,3)_"@"_$E(DGTM,1,4)
  1.  W ?61,$E($P(DGY,U,10),1,15)  ;admiting dx
  1.  I $Y>(IOSL-6) D NEWPG
  1.  Q
  1.  ;
  1. NOICU ;***> subrtn called if facility doesn't have an ICU
  1.  W !!,"***** THERE IS NO ICU WARD SET UP ON YOUR SYSTEM ****",!!!
  1.  G END1
  1.  ;
  1. NEWPG ;***> subrtn for end of page control
  1.  I IOST'?1"C-".E D HDR S DGSTOP="" Q
  1.  K DIR S DIR(0)="E" D ^DIR S DGSTOP=X I DGSTOP'=U D HDR Q
  1.  ;
  1. HDR ;***> subrtn to print heading
  1.  W:IOST?1"C-".E @IOF I IOST?1"P-".E W:DGPAGE @IOF
  1.  W !,DGLINE S DGPAGE=DGPAGE+1
  1.  W !?11,"*****Confidential Patient Data Covered by Privacy Act*****"
  1.  W !,DGDUZ,?80-$L(DGFAC)/2,DGFAC S DGTY="TRANSFERS TO ICU"
  1.  W ! D TIME^ADGUTIL W ?80-$L(DGTY)/2,DGTY,?70,"Page: ",DGPAGE
  1.  S Y=DT X ^DD("DD") W !,Y,!,DGLINE
  1.  W !,"Patient",?21,"Chart #",?32,"Admit Date",?45,"Transfer Date"
  1.  W ?60,"Admitting Diagnosis",!,DGLIN1,!
  1.  Q