- 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
