ADGRALP ; IHS/ADC/PDW/ENM - READMISSION 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 DGSITE=$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^ADGRALP1:DGTYP=2,SERV^ADGRALP1:DGTYP=3 ;sort?
;
DATE ;***> admit date order
S DGDT=0
DT1 S DGDT=$O(^TMP("DGZRAL",$J,DGDT)) G END:DGDT="" S DGTM=0
I DGPAGE=0 D NEWPG G END1:DGSTOP=U
DT2 S DGTM=$O(^TMP("DGZRAL",$J,DGDT,DGTM)) G DT1:DGTM="" S DFN=0
DT3 S DFN=$O(^TMP("DGZRAL",$J,DGDT,DGTM,DFN)) G DT2:DFN=""
S DGS=^TMP("DGZRAL",$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)
S DGRE=$P(DGS,U,4),DGDSA=$P(DGS,U,5),DGDS=$P(DGS,U,6)
S DGLST=$P(DGS,U,7),DGA=$P(DGS,U,8)
D LINE G END1:DGSTOP=U G DT3
;
;
END ;***> eoj
I IOST["C-" K DIR S DIR(0)="E" D ^DIR
END1 ;EP;
W @IOF D KILL^ADGUTIL
D ^%ZISC K ^TMP("DGZRAL") Q
;
LINE ;***> subrtn to print patient data
W !!,$E(DGNM,1,20) ;patient name
W ?27,$E(DGTM,4,5)_"/"_$E(DGTM,6,7)_"/"_$E(DGTM,2,3) ;admit date
W "@"_$E($P(DGTM,".",2)_"000",1,4) ;admit time
W ?41,$E(DGSV,1,3),?48,$E(DGW,1,3) ;service & ward
W ?53,$E(DGDX,1,25) ;admit dx
S DGX=$P(^AUPNPAT(DFN,41,DUZ(2),0),U,2) W !,"[#",$J(DGX,6),"]" ;chart
I DGRE["A" D ;if readmission
.W ?11,"Last Admission:"
.W ?27,$E(DGLST,4,5)_"/"_$E(DGLST,6,7)_"/"_$E(DGLST,2,3) ;last admit
.W "@"_$E($P(DGLST,".",2)_"000",1,4) ;last admit time
.S DGSVL=$P($G(^DIC(45.7,+$$TS,0)),U) ;srv
.S DGWRD=$P(^DIC(42,$P(^DGPM(DGA,0),U,6),0),U) ;ward
.W ?41,$E(DGSVL,1,3),?48,$E(DGWRD,1,3) ;last srv & wrd
.S DGDX=$P(^DGPM(DGA,0),U,10) W ?53,$E(DGDX,1,25) ;admit dx
E D ;if admission is after day surgery
.W:DGRE["DS" ?11,"Admit from DS:"
.W:DGRE'["S" ?11,"Day Surgery:"
.W ?27,$E(DGDS,4,5)_"/"_$E(DGDS,6,7)_"/"_$E(DGDS,2,3) ;ds date
.W "@"_$E($P(DGDS,".",2)_"000",1,4) ;ds time
.S DGDSTR=^ADGDS(DFN,"DS",DGDSA,0)
.S DGSRVL=$P(^DIC(45.7,$P(DGDSTR,U,5),0),U) ;ds service
.S DGPROC=$P(DGDSTR,U,2) ;ds procedure
.W ?41,$E(DGSRVL,1,3),?53,$E(DGPROC,1,25) ;print srv & proc
I $Y>(IOSL-4) D NEWPG
Q
;
NEWPG ;EP;***> 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(DGSITE)/2,DGSITE S DGTY="READMISSIONS"
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,"Admit",?57,"Admitting Diagnosis /"
W !?54,"Admitting Diagnosis /",!,"Patient Name"
I DGTYP=1 W ?29,"Date/Time",?41,"Srv",?47,"Ward"
I DGTYP=2 W ?33,"Admit Date",?48,"Srv"
I DGTYP=3 W ?33,"Admit Date",?47,"Ward"
W:$O(^ADGDS(0)) ?58,"Day Surg Procedure" W !,DGLINE2
I DGTYP>1 S DGX="** "_$S(DGTYP=2:DGW,1:DGSV)_" **" W !!?80-$L(DGX)/2,DGX
Q
;
TS() ; -- treating specialty ifn
Q $P($G(^DGPM(+$O(^DGPM("APHY",DGA,0)),0)),U,9)
ADGRALP ; IHS/ADC/PDW/ENM - READMISSION 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 DGSITE=$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 ;sort?
IF DGTYP=1
GOTO DATE
IF DGTYP=2
GOTO WARD^ADGRALP1
IF DGTYP=3
GOTO SERV^ADGRALP1
+12 ;
DATE ;***> admit date order
+1 SET DGDT=0
DT1 SET DGDT=$ORDER(^TMP("DGZRAL",$JOB,DGDT))
IF DGDT=""
GOTO END
SET DGTM=0
+1 IF DGPAGE=0
DO NEWPG
IF DGSTOP=U
GOTO END1
DT2 SET DGTM=$ORDER(^TMP("DGZRAL",$JOB,DGDT,DGTM))
IF DGTM=""
GOTO DT1
SET DFN=0
DT3 SET DFN=$ORDER(^TMP("DGZRAL",$JOB,DGDT,DGTM,DFN))
IF DFN=""
GOTO DT2
+1 SET DGS=^TMP("DGZRAL",$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 SET DGRE=$PIECE(DGS,U,4)
SET DGDSA=$PIECE(DGS,U,5)
SET DGDS=$PIECE(DGS,U,6)
+5 SET DGLST=$PIECE(DGS,U,7)
SET DGA=$PIECE(DGS,U,8)
+6 DO LINE
IF DGSTOP=U
GOTO END1
GOTO DT3
+7 ;
+8 ;
END ;***> eoj
+1 IF IOST["C-"
KILL DIR
SET DIR(0)="E"
DO ^DIR
END1 ;EP;
+1 WRITE @IOF
DO KILL^ADGUTIL
+2 DO ^%ZISC
KILL ^TMP("DGZRAL")
QUIT
+3 ;
LINE ;***> subrtn to print patient data
+1 ;patient name
WRITE !!,$EXTRACT(DGNM,1,20)
+2 ;admit date
WRITE ?27,$EXTRACT(DGTM,4,5)_"/"_$EXTRACT(DGTM,6,7)_"/"_$EXTRACT(DGTM,2,3)
+3 ;admit time
WRITE "@"_$EXTRACT($PIECE(DGTM,".",2)_"000",1,4)
+4 ;service & ward
WRITE ?41,$EXTRACT(DGSV,1,3),?48,$EXTRACT(DGW,1,3)
+5 ;admit dx
WRITE ?53,$EXTRACT(DGDX,1,25)
+6 ;chart
SET DGX=$PIECE(^AUPNPAT(DFN,41,DUZ(2),0),U,2)
WRITE !,"[#",$JUSTIFY(DGX,6),"]"
+7 ;if readmission
IF DGRE["A"
Begin DoDot:1
+8 WRITE ?11,"Last Admission:"
+9 ;last admit
WRITE ?27,$EXTRACT(DGLST,4,5)_"/"_$EXTRACT(DGLST,6,7)_"/"_$EXTRACT(DGLST,2,3)
+10 ;last admit time
WRITE "@"_$EXTRACT($PIECE(DGLST,".",2)_"000",1,4)
+11 ;srv
SET DGSVL=$PIECE($GET(^DIC(45.7,+$$TS,0)),U)
+12 ;ward
SET DGWRD=$PIECE(^DIC(42,$PIECE(^DGPM(DGA,0),U,6),0),U)
+13 ;last srv & wrd
WRITE ?41,$EXTRACT(DGSVL,1,3),?48,$EXTRACT(DGWRD,1,3)
+14 ;admit dx
SET DGDX=$PIECE(^DGPM(DGA,0),U,10)
WRITE ?53,$EXTRACT(DGDX,1,25)
End DoDot:1
+15 ;if admission is after day surgery
IF '$TEST
Begin DoDot:1
+16 IF DGRE["DS"
WRITE ?11,"Admit from DS:"
+17 IF DGRE'["S"
WRITE ?11,"Day Surgery:"
+18 ;ds date
WRITE ?27,$EXTRACT(DGDS,4,5)_"/"_$EXTRACT(DGDS,6,7)_"/"_$EXTRACT(DGDS,2,3)
+19 ;ds time
WRITE "@"_$EXTRACT($PIECE(DGDS,".",2)_"000",1,4)
+20 SET DGDSTR=^ADGDS(DFN,"DS",DGDSA,0)
+21 ;ds service
SET DGSRVL=$PIECE(^DIC(45.7,$PIECE(DGDSTR,U,5),0),U)
+22 ;ds procedure
SET DGPROC=$PIECE(DGDSTR,U,2)
+23 ;print srv & proc
WRITE ?41,$EXTRACT(DGSRVL,1,3),?53,$EXTRACT(DGPROC,1,25)
End DoDot:1
+24 IF $Y>(IOSL-4)
DO NEWPG
+25 QUIT
+26 ;
NEWPG ;EP;***> 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(DGSITE)/2,DGSITE
SET DGTY="READMISSIONS"
+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,"Admit",?57,"Admitting Diagnosis /"
+10 WRITE !?54,"Admitting Diagnosis /",!,"Patient Name"
+11 IF DGTYP=1
WRITE ?29,"Date/Time",?41,"Srv",?47,"Ward"
+12 IF DGTYP=2
WRITE ?33,"Admit Date",?48,"Srv"
+13 IF DGTYP=3
WRITE ?33,"Admit Date",?47,"Ward"
+14 IF $ORDER(^ADGDS(0))
WRITE ?58,"Day Surg Procedure"
WRITE !,DGLINE2
+15 IF DGTYP>1
SET DGX="** "_$SELECT(DGTYP=2:DGW,1:DGSV)_" **"
WRITE !!?80-$LENGTH(DGX)/2,DGX
+16 QUIT
+17 ;
TS() ; -- treating specialty ifn
+1 QUIT $PIECE($GET(^DGPM(+$ORDER(^DGPM("APHY",DGA,0)),0)),U,9)
