ADGLDCP ; IHS/ADC/PDW/ENM - DISCHARGES LISTING (PRINT) ; [ 03/25/1999 11:48 AM ]
;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
;
;***> initialize variables
S DGPAGE=0,DGSTOP="",DGDUZ=$P(^VA(200,DUZ,0),U,2)
S DGFAC=$P(^DIC(4,DUZ(2),0),U) ;set site
S DGRANGE=$E(DGBDT,4,5)_"/"_$E(DGBDT,6,7)_"/"_$E(DGBDT,2,3)_" to "
S DGRANGE=DGRANGE_$E(DGEDT,4,5)_"/"_$E(DGEDT,6,7)_"/"_$E(DGEDT,2,3)
S DGLINE="",$P(DGLINE,"=",80)=""
S DGLINE2="",$P(DGLINE2,"-",80)=""
;
G DATE:DGTYP=1,WARD:DGTYP=2,SERV:DGTYP=3 ;what sort order?
;
DATE ;***> discharge date order
S DGDT=0
DT1 S DGDT=$O(^TMP("DGZLDC",$J,DGDT)) G END:DGDT="" S DGTM=0
D NEWPG G END1:DGSTOP=U
DT2 S DGTM=$O(^TMP("DGZLDC",$J,DGDT,DGTM)) G DT1:DGTM="" S DFN=0
DT3 S DFN=$O(^TMP("DGZLDC",$J,DGDT,DGTM,DFN)) G DT2:DFN=""
S DGS=^TMP("DGZLDC",$J,DGDT,DGTM,DFN)
S DGW=$P(DGS,U),DGSV=$P(DGS,U,2),DGDX=$P(DGS,U,3)
S DGNM=$P(^DPT(DFN,0),U),DGTIM=$E($P(DGTM,".",2)_"000",1,4)
D LINE G END1:DGSTOP=U G DT3
;
WARD ;***> in order by ward
S DGW=0
WD1 S DGW=$O(^TMP("DGZLDC",$J,DGW)) G END:DGW="" S DGDT=0
I DGPAGE=0!(DGBDT'=DGEDT) D NEWPG G END1:DGSTOP=U
I DGPAGE>0,DGBDT=DGEDT W !!?35,"** ",$E(DGW,1,3)," **"
WD2 S DGDT=$O(^TMP("DGZLDC",$J,DGW,DGDT)) G WD1:DGDT="" S DGNM=0
WD3 S DGNM=$O(^TMP("DGZLDC",$J,DGW,DGDT,DGNM)) G WD2:DGNM="" S DFN=0
WD4 S DFN=$O(^TMP("DGZLDC",$J,DGW,DGDT,DGNM,DFN)) G WD3:DFN=""
S DGS=^TMP("DGZLDC",$J,DGW,DGDT,DGNM,DFN)
S DGSV=$P(DGS,U),DGDX=$P(DGS,U,2)
D LINE G END1:DGSTOP=U G WD4
;
SERV ;***> admit service order
S DGSV=0
SV1 S DGSV=$O(^TMP("DGZLDC",$J,DGSV)) G END:DGSV="" S DGDT=0
I DGPAGE=0!(DGBDT'=DGEDT) D NEWPG G END1:DGSTOP=U
I DGPAGE>0,DGBDT=DGEDT W !!?35,"** ",$E(DGSV,1,3)," **"
SV2 S DGDT=$O(^TMP("DGZLDC",$J,DGSV,DGDT)) G SV1:DGDT="" S DGNM=0
SV3 S DGNM=$O(^TMP("DGZLDC",$J,DGSV,DGDT,DGNM)) G SV2:DGNM="" S DFN=0
SV4 S DFN=$O(^TMP("DGZLDC",$J,DGSV,DGDT,DGNM,DFN)) G SV3:DFN=""
S DGS=^TMP("DGZLDC",$J,DGSV,DGDT,DGNM,DFN)
S DGW=$P(DGS,U),DGDX=$P(DGS,U,2)
D LINE G END1:DGSTOP=U G SV4
;
;
END ;***> eoj
I IOST["C-" K DIR S DIR(0)="E" D ^DIR
END1 W @IOF D KILL^ADGUTIL
D ^%ZISC K ^TMP("DGZLDC") Q
;
;
LINE ;***> subrtn to print patient data
W !,$E(DGNM,1,20) ;patient name
S DGX=$P(^AUPNPAT(DFN,41,DUZ(2),0),U,2) W ?23,$J(DGX,6) ;chart #
I DGTYP=1 W ?32,DGTIM,?41,$E(DGSV,1,3),?48,$E(DGW,1,3) ;time,service & ward
I DGTYP>1 W ?32,$E(DGDT,4,5)_"/"_$E(DGDT,6,7)_"/"_$E(DGDT,2,3)_"@"_$E($P(DGDT,".",2)_"000",1,4)
W ?48,$S(DGTYP=2:$E(DGSV,1,3),DGTYP=3:$E(DGW,1,3),1:"")
W ?55,$E(DGDX,1,25) ;admit dx
I $Y>(IOSL-4) D NEWPG
Q
;
NEWPG ;***> subrtn for end of page control
I IOST'?1"C-".E D HEAD S DGSTOP="" Q
I DGPAGE>0 K DIR S DIR(0)="E" D ^DIR S DGSTOP=X
I DGSTOP'=U D HEAD
Q
;
HEAD ;***> subrtn to print heading
I (IOST["C-")!(DGPAGE>0) W @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="DISCHARGES"
W ! D TIME^ADGUTIL W ?80-$L(DGTY)/2,DGTY,?70,"Page: ",DGPAGE
S Y=DT X ^DD("DD") W !,Y,?30,DGRANGE ;date range
S DGX="(SORTED BY "_$S(DGTYP=1:"DATE",DGTYP=2:"WARD",1:"SERVICE")_")"
W !?80-$L(DGX)/2,DGX
W !,DGLINE I DGTYP=1 W !?32,"Dsch"
W !,"Patient Name",?24,"HRCN"
I DGTYP=1 W ?32,"Time",?41,"Srv",?47,"Ward",?57,"Admitting Diagnosis"
I DGTYP=2 W ?33,"Dsch Date",?48,"Srv",?57,"Admitting Diagnosis"
I DGTYP=3 W ?33,"Dsch Date",?47,"Ward",?58,"Admitting Diagnosis"
W !,DGLINE2
I DGTYP=1 W !!?25,"** Discharged on ",$E(DGDT,4,5)_"/"_$E(DGDT,6,7)_"/"_$E(DGDT,2,3)," **",!
E I DGBDT'=DGEDT S DGX="** "_$S(DGTYP=2:DGW,1:DGSV)_" **" W !!?80-$L(DGX)/2,DGX
Q
ADGLDCP ; IHS/ADC/PDW/ENM - DISCHARGES LISTING (PRINT) ; [ 03/25/1999 11:48 AM ]
+1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
+2 ;
+3 ;***> initialize variables
+4 SET DGPAGE=0
SET DGSTOP=""
SET DGDUZ=$PIECE(^VA(200,DUZ,0),U,2)
+5 ;set site
SET DGFAC=$PIECE(^DIC(4,DUZ(2),0),U)
+6 SET DGRANGE=$EXTRACT(DGBDT,4,5)_"/"_$EXTRACT(DGBDT,6,7)_"/"_$EXTRACT(DGBDT,2,3)_" to "
+7 SET DGRANGE=DGRANGE_$EXTRACT(DGEDT,4,5)_"/"_$EXTRACT(DGEDT,6,7)_"/"_$EXTRACT(DGEDT,2,3)
+8 SET DGLINE=""
SET $PIECE(DGLINE,"=",80)=""
+9 SET DGLINE2=""
SET $PIECE(DGLINE2,"-",80)=""
+10 ;
+11 ;what sort order?
IF DGTYP=1
GOTO DATE
IF DGTYP=2
GOTO WARD
IF DGTYP=3
GOTO SERV
+12 ;
DATE ;***> discharge date order
+1 SET DGDT=0
DT1 SET DGDT=$ORDER(^TMP("DGZLDC",$JOB,DGDT))
IF DGDT=""
GOTO END
SET DGTM=0
+1 DO NEWPG
IF DGSTOP=U
GOTO END1
DT2 SET DGTM=$ORDER(^TMP("DGZLDC",$JOB,DGDT,DGTM))
IF DGTM=""
GOTO DT1
SET DFN=0
DT3 SET DFN=$ORDER(^TMP("DGZLDC",$JOB,DGDT,DGTM,DFN))
IF DFN=""
GOTO DT2
+1 SET DGS=^TMP("DGZLDC",$JOB,DGDT,DGTM,DFN)
+2 SET DGW=$PIECE(DGS,U)
SET DGSV=$PIECE(DGS,U,2)
SET DGDX=$PIECE(DGS,U,3)
+3 SET DGNM=$PIECE(^DPT(DFN,0),U)
SET DGTIM=$EXTRACT($PIECE(DGTM,".",2)_"000",1,4)
+4 DO LINE
IF DGSTOP=U
GOTO END1
GOTO DT3
+5 ;
WARD ;***> in order by ward
+1 SET DGW=0
WD1 SET DGW=$ORDER(^TMP("DGZLDC",$JOB,DGW))
IF DGW=""
GOTO END
SET DGDT=0
+1 IF DGPAGE=0!(DGBDT'=DGEDT)
DO NEWPG
IF DGSTOP=U
GOTO END1
+2 IF DGPAGE>0
IF DGBDT=DGEDT
WRITE !!?35,"** ",$EXTRACT(DGW,1,3)," **"
WD2 SET DGDT=$ORDER(^TMP("DGZLDC",$JOB,DGW,DGDT))
IF DGDT=""
GOTO WD1
SET DGNM=0
WD3 SET DGNM=$ORDER(^TMP("DGZLDC",$JOB,DGW,DGDT,DGNM))
IF DGNM=""
GOTO WD2
SET DFN=0
WD4 SET DFN=$ORDER(^TMP("DGZLDC",$JOB,DGW,DGDT,DGNM,DFN))
IF DFN=""
GOTO WD3
+1 SET DGS=^TMP("DGZLDC",$JOB,DGW,DGDT,DGNM,DFN)
+2 SET DGSV=$PIECE(DGS,U)
SET DGDX=$PIECE(DGS,U,2)
+3 DO LINE
IF DGSTOP=U
GOTO END1
GOTO WD4
+4 ;
SERV ;***> admit service order
+1 SET DGSV=0
SV1 SET DGSV=$ORDER(^TMP("DGZLDC",$JOB,DGSV))
IF DGSV=""
GOTO END
SET DGDT=0
+1 IF DGPAGE=0!(DGBDT'=DGEDT)
DO NEWPG
IF DGSTOP=U
GOTO END1
+2 IF DGPAGE>0
IF DGBDT=DGEDT
WRITE !!?35,"** ",$EXTRACT(DGSV,1,3)," **"
SV2 SET DGDT=$ORDER(^TMP("DGZLDC",$JOB,DGSV,DGDT))
IF DGDT=""
GOTO SV1
SET DGNM=0
SV3 SET DGNM=$ORDER(^TMP("DGZLDC",$JOB,DGSV,DGDT,DGNM))
IF DGNM=""
GOTO SV2
SET DFN=0
SV4 SET DFN=$ORDER(^TMP("DGZLDC",$JOB,DGSV,DGDT,DGNM,DFN))
IF DFN=""
GOTO SV3
+1 SET DGS=^TMP("DGZLDC",$JOB,DGSV,DGDT,DGNM,DFN)
+2 SET DGW=$PIECE(DGS,U)
SET DGDX=$PIECE(DGS,U,2)
+3 DO LINE
IF DGSTOP=U
GOTO END1
GOTO SV4
+4 ;
+5 ;
END ;***> eoj
+1 IF IOST["C-"
KILL DIR
SET DIR(0)="E"
DO ^DIR
END1 WRITE @IOF
DO KILL^ADGUTIL
+1 DO ^%ZISC
KILL ^TMP("DGZLDC")
QUIT
+2 ;
+3 ;
LINE ;***> subrtn to print patient data
+1 ;patient name
WRITE !,$EXTRACT(DGNM,1,20)
+2 ;chart #
SET DGX=$PIECE(^AUPNPAT(DFN,41,DUZ(2),0),U,2)
WRITE ?23,$JUSTIFY(DGX,6)
+3 ;time,service & ward
IF DGTYP=1
WRITE ?32,DGTIM,?41,$EXTRACT(DGSV,1,3),?48,$EXTRACT(DGW,1,3)
+4 IF DGTYP>1
WRITE ?32,$EXTRACT(DGDT,4,5)_"/"_$EXTRACT(DGDT,6,7)_"/"_$EXTRACT(DGDT,2,3)_"@"_$EXTRACT($PIECE(DGDT,".",2)_"000",1,4)
+5 WRITE ?48,$SELECT(DGTYP=2:$EXTRACT(DGSV,1,3),DGTYP=3:$EXTRACT(DGW,1,3),1:"")
+6 ;admit dx
WRITE ?55,$EXTRACT(DGDX,1,25)
+7 IF $Y>(IOSL-4)
DO NEWPG
+8 QUIT
+9 ;
NEWPG ;***> subrtn for end of page control
+1 IF IOST'?1"C-".E
DO HEAD
SET DGSTOP=""
QUIT
+2 IF DGPAGE>0
KILL DIR
SET DIR(0)="E"
DO ^DIR
SET DGSTOP=X
+3 IF DGSTOP'=U
DO HEAD
+4 QUIT
+5 ;
HEAD ;***> subrtn to print heading
+1 IF (IOST["C-")!(DGPAGE>0)
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="DISCHARGES"
+5 WRITE !
DO TIME^ADGUTIL
WRITE ?80-$LENGTH(DGTY)/2,DGTY,?70,"Page: ",DGPAGE
+6 ;date range
SET Y=DT
XECUTE ^DD("DD")
WRITE !,Y,?30,DGRANGE
+7 SET DGX="(SORTED BY "_$SELECT(DGTYP=1:"DATE",DGTYP=2:"WARD",1:"SERVICE")_")"
+8 WRITE !?80-$LENGTH(DGX)/2,DGX
+9 WRITE !,DGLINE
IF DGTYP=1
WRITE !?32,"Dsch"
+10 WRITE !,"Patient Name",?24,"HRCN"
+11 IF DGTYP=1
WRITE ?32,"Time",?41,"Srv",?47,"Ward",?57,"Admitting Diagnosis"
+12 IF DGTYP=2
WRITE ?33,"Dsch Date",?48,"Srv",?57,"Admitting Diagnosis"
+13 IF DGTYP=3
WRITE ?33,"Dsch Date",?47,"Ward",?58,"Admitting Diagnosis"
+14 WRITE !,DGLINE2
+15 IF DGTYP=1
WRITE !!?25,"** Discharged on ",$EXTRACT(DGDT,4,5)_"/"_$EXTRACT(DGDT,6,7)_"/"_$EXTRACT(DGDT,2,3)," **",!
+16 IF '$TEST
IF DGBDT'=DGEDT
SET DGX="** "_$SELECT(DGTYP=2:DGW,1:DGSV)_" **"
WRITE !!?80-$LENGTH(DGX)/2,DGX
+17 QUIT
