ADGING21 ; IHS/ADC/PDW/ENM - INPATIENT > 21 DAYS ; [ 03/25/1999 11:48 AM ]
;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
;
A ; -- entry point
N DIR S DIR(0)="NO",DIR("A")="Enter number of Days"
S DIR("?")="What is the minimum length of stay for this report?"
D ^DIR I $D(DIRUT) D Q Q
S DGND=Y
I DGND[U D Q Q
I DGND="" D Q Q
G:'DGND A
D ZIS G:POP!($D(IO("Q"))) Q
D DT,LP,Q
Q
QUE ; -- queued entry point
D DT,LP,Q
Q
ZIS ; -- device selection
S %ZIS="PQ"
D ^%ZIS Q:POP
I $D(IO("Q")) D TM
Q
DT ; -- date (today - 21 days)
N X1,X2,X
S X1=DT,X2=-DGND D C^%DTC S DGZDT=X
Q
LP ; -- loop inpatient by ward
N WRD,DFN,ADM,TOT
U IO S DGSTOP="",DGPG=0
S (WRD,DFN,ADM)="",TOT=0 D HDH
F S WRD=$O(^DPT("CN",WRD)) Q:WRD=""!(DGSTOP=U) D
. F S DFN=$O(^DPT("CN",WRD,DFN)) Q:'+DFN!(DGSTOP=U) D
.. S ADM=^DPT("CN",WRD,DFN)
.. I +^DGPM(ADM,0)<DGZDT S TOT=TOT+1 D WRT
Q:DGSTOP=U
W !!,"Total: ",TOT,!!
Q
WRT ; -- print patient info
N X,X1,X2,Y
I $Y>(IOSL-4) D NEWPG Q:DGSTOP=U
W !,$E($P(^DPT(DFN,0),U),1,25) ;name
W ?27,$J($P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2),9) ;HRCN
S X1=DT,X2=$P(^DPT(DFN,0),U,3) D ^%DTC S X=X\365.25
W ?37,$J(X,3) ;age
W ?42,$E(WRD,1,5) ;ward
S Y=+^DGPM(ADM,0) X ^DD("DD")
W ?48,$P(Y,",",1) ;admission date
S X1=DT,X2=+^DGPM(ADM,0) D ^%DTC W ?57,X ;los
W ?63,$E($P(^AUPNPAT(DFN,11),U,18),1,12) ;community
W ?76,$E($P(^DIC(45.7,^DPT(DFN,.103),0),U),1,3) ;service
Q
HDH ; -- heading
N X,Y
I DGPG>0!(IOST["C-") W @IOF
S DGPG=DGPG+1
W !,"PATIENTS WITH ",DGND," INPATIENT DAYS OR MORE"
D NOW^%DTC S Y=X X ^DD("DD")
W ?65,Y
W !?5,"NAME",?31,"HRCN",?37,"AGE",?42,"WARD",?48,"ADM DT"
W ?57,"LOS",?63,"COMMUNITY",?76,"SRV"
S X="",$P(X,"-",IOM)=""
W !,X
Q
;
NEWPG ; -- end of page control
I IOST["C-" K DIR S DIR(0)="E" D ^DIR S DGSTOP=X Q:X=U
D HDH Q
;
TM ; -- tasked output
S ZTRTN="QUE^ADGING21",ZTIO=ION,ZTDESC="INPATIENTS > 21 DAYS"
S ZTSAVE("DGND")="" D ^%ZTLOAD
Q
Q ; -- cleanup
I $G(DGSTOP)="",IOST["C-" D PRTOPT^ADGVAR
D ^%ZISC D HOME^%ZIS
K DGND,DGZDT,DGSTOP,DGPG,DIRUT Q
ADGING21 ; IHS/ADC/PDW/ENM - INPATIENT > 21 DAYS ; [ 03/25/1999 11:48 AM ]
+1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
+2 ;
A ; -- entry point
+1 NEW DIR
SET DIR(0)="NO"
SET DIR("A")="Enter number of Days"
+2 SET DIR("?")="What is the minimum length of stay for this report?"
+3 DO ^DIR
IF $DATA(DIRUT)
DO Q
QUIT
+4 SET DGND=Y
+5 IF DGND[U
DO Q
QUIT
+6 IF DGND=""
DO Q
QUIT
+7 IF 'DGND
GOTO A
+8 DO ZIS
IF POP!($DATA(IO("Q")))
GOTO Q
+9 DO DT
DO LP
DO Q
+10 QUIT
QUE ; -- queued entry point
+1 DO DT
DO LP
DO Q
+2 QUIT
ZIS ; -- device selection
+1 SET %ZIS="PQ"
+2 DO ^%ZIS
IF POP
QUIT
+3 IF $DATA(IO("Q"))
DO TM
+4 QUIT
DT ; -- date (today - 21 days)
+1 NEW X1,X2,X
+2 SET X1=DT
SET X2=-DGND
DO C^%DTC
SET DGZDT=X
+3 QUIT
LP ; -- loop inpatient by ward
+1 NEW WRD,DFN,ADM,TOT
+2 USE IO
SET DGSTOP=""
SET DGPG=0
+3 SET (WRD,DFN,ADM)=""
SET TOT=0
DO HDH
+4 FOR
SET WRD=$ORDER(^DPT("CN",WRD))
IF WRD=""!(DGSTOP=U)
QUIT
Begin DoDot:1
+5 FOR
SET DFN=$ORDER(^DPT("CN",WRD,DFN))
IF '+DFN!(DGSTOP=U)
QUIT
Begin DoDot:2
+6 SET ADM=^DPT("CN",WRD,DFN)
+7 IF +^DGPM(ADM,0)<DGZDT
SET TOT=TOT+1
DO WRT
End DoDot:2
End DoDot:1
+8 IF DGSTOP=U
QUIT
+9 WRITE !!,"Total: ",TOT,!!
+10 QUIT
WRT ; -- print patient info
+1 NEW X,X1,X2,Y
+2 IF $Y>(IOSL-4)
DO NEWPG
IF DGSTOP=U
QUIT
+3 ;name
WRITE !,$EXTRACT($PIECE(^DPT(DFN,0),U),1,25)
+4 ;HRCN
WRITE ?27,$JUSTIFY($PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2),9)
+5 SET X1=DT
SET X2=$PIECE(^DPT(DFN,0),U,3)
DO ^%DTC
SET X=X\365.25
+6 ;age
WRITE ?37,$JUSTIFY(X,3)
+7 ;ward
WRITE ?42,$EXTRACT(WRD,1,5)
+8 SET Y=+^DGPM(ADM,0)
XECUTE ^DD("DD")
+9 ;admission date
WRITE ?48,$PIECE(Y,",",1)
+10 ;los
SET X1=DT
SET X2=+^DGPM(ADM,0)
DO ^%DTC
WRITE ?57,X
+11 ;community
WRITE ?63,$EXTRACT($PIECE(^AUPNPAT(DFN,11),U,18),1,12)
+12 ;service
WRITE ?76,$EXTRACT($PIECE(^DIC(45.7,^DPT(DFN,.103),0),U),1,3)
+13 QUIT
HDH ; -- heading
+1 NEW X,Y
+2 IF DGPG>0!(IOST["C-")
WRITE @IOF
+3 SET DGPG=DGPG+1
+4 WRITE !,"PATIENTS WITH ",DGND," INPATIENT DAYS OR MORE"
+5 DO NOW^%DTC
SET Y=X
XECUTE ^DD("DD")
+6 WRITE ?65,Y
+7 WRITE !?5,"NAME",?31,"HRCN",?37,"AGE",?42,"WARD",?48,"ADM DT"
+8 WRITE ?57,"LOS",?63,"COMMUNITY",?76,"SRV"
+9 SET X=""
SET $PIECE(X,"-",IOM)=""
+10 WRITE !,X
+11 QUIT
+12 ;
NEWPG ; -- end of page control
+1 IF IOST["C-"
KILL DIR
SET DIR(0)="E"
DO ^DIR
SET DGSTOP=X
IF X=U
QUIT
+2 DO HDH
QUIT
+3 ;
TM ; -- tasked output
+1 SET ZTRTN="QUE^ADGING21"
SET ZTIO=ION
SET ZTDESC="INPATIENTS > 21 DAYS"
+2 SET ZTSAVE("DGND")=""
DO ^%ZTLOAD
+3 QUIT
Q ; -- cleanup
+1 IF $GET(DGSTOP)=""
IF IOST["C-"
DO PRTOPT^ADGVAR
+2 DO ^%ZISC
DO HOME^%ZIS
+3 KILL DGND,DGZDT,DGSTOP,DGPG,DIRUT
QUIT
