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