ADGRALP1 ; IHS/ADC/PDW/ENM - READMISSION LISTING (PRINT) ; [ 03/25/1999 11:48 AM ]
;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
;
WARD ;EP;***> in order by ward
S DGW=0
WD1 S DGW=$O(^TMP("DGZRAL",$J,DGW)) G END:DGW="" S DGDT=0
I DGPAGE=0!(DGBDT'=DGEDT) D NEWPG^ADGRALP G END1:DGSTOP="^"
I DGPAGE>0,DGBDT=DGEDT W !!?35,"** ",$E(DGW,1,3)," **"
WD2 S DGDT=$O(^TMP("DGZRAL",$J,DGW,DGDT)) G WD1:DGDT="" S DGNM=0
WD3 S DGNM=$O(^TMP("DGZRAL",$J,DGW,DGDT,DGNM)) G WD2:DGNM="" S DFN=0
WD4 S DFN=$O(^TMP("DGZRAL",$J,DGW,DGDT,DGNM,DFN)) G WD3:DFN=""
S DGS=^TMP("DGZRAL",$J,DGW,DGDT,DGNM,DFN)
S DGSV=$P(DGS,U),DGDX=$P(DGS,U,2),DGRE=$P(DGS,U,3)
S DGDSA=$P(DGS,U,4),DGDS=$P(DGS,U,5),DGLST=$P(DGS,U,6),DGA=$P(DGS,U,7)
D LINE G END1:DGSTOP="^" G WD4
;
SERV ;EP;***> admit service order
S DGSV=0
SV1 S DGSV=$O(^TMP("DGZRAL",$J,DGSV)) G END:DGSV="" S DGDT=0
I DGPAGE=0!(DGBDT'=DGEDT) D NEWPG^ADGRALP G END1:DGSTOP="^"
I DGPAGE>0,DGBDT=DGEDT W !!?35,"** ",$E(DGSV,1,3)," **"
SV2 S DGDT=$O(^TMP("DGZRAL",$J,DGSV,DGDT)) G SV1:DGDT="" S DGNM=0
SV3 S DGNM=$O(^TMP("DGZRAL",$J,DGSV,DGDT,DGNM)) G SV2:DGNM="" S DFN=0
SV4 S DFN=$O(^TMP("DGZRAL",$J,DGSV,DGDT,DGNM,DFN)) G SV3:DFN=""
S DGS=^TMP("DGZRAL",$J,DGSV,DGDT,DGNM,DFN)
S DGW=$P(DGS,U),DGDX=$P(DGS,U,2),DGRE=$P(DGS,U,3)
S DGDSA=$P(DGS,U,4),DGDS=$P(DGS,U,5),DGLST=$P(DGS,U,6),DGA=$P(DGS,U,7)
D LINE G END1:DGSTOP="^" G SV4
;
;***> eoj
END I IOST["C-" K DIR S DIR(0)="E" D ^DIR
END1 G END1^ADGRALP
;
LINE ;***> subrtn to print patient data
W !!,$E(DGNM,1,20) ;patient name
W ?32,$E(DGDT,4,5)_"/"_$E(DGDT,6,7)_"/"_$E(DGDT,2,3) ;admit date
W "@"_$E($P(DGDT,".",2)_"000",1,4) ;admit time
W ?48,$S(DGTYP=2:$E(DGSV,1,3),DGTYP=3:$E(DGW,1,3),1:"")
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 ?32,$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)
.S DGWRD=$P(^DIC(42,$P(^DGPM(+DGA,0),U,6),0),U)
.W ?48,$S(DGTYP=2:$E(DGSVL,1,3),DGTYP=3:$E(DGWRD,1,3),1:"")
.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 ?32,$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 srv
.S DGPROC=$P(DGDSTR,U,2) ;ds procedure
.W ?48,$S(DGTYP=2:$E(DGSV,1,3),1:"")
.W ?53,$E(DGPROC,1,25) ;admit proc
I $Y>(IOSL-4) D NEWPG^ADGRALP
Q
;
TS() ; -- treating specialty ifn
Q $P($G(^DGPM(+$O(^DGPM("APHY",+DGA,0)),0)),U,9)
ADGRALP1 ; IHS/ADC/PDW/ENM - READMISSION LISTING (PRINT) ; [ 03/25/1999 11:48 AM ]
+1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
+2 ;
WARD ;EP;***> in order by ward
+1 SET DGW=0
WD1 SET DGW=$ORDER(^TMP("DGZRAL",$JOB,DGW))
IF DGW=""
GOTO END
SET DGDT=0
+1 IF DGPAGE=0!(DGBDT'=DGEDT)
DO NEWPG^ADGRALP
IF DGSTOP="^"
GOTO END1
+2 IF DGPAGE>0
IF DGBDT=DGEDT
WRITE !!?35,"** ",$EXTRACT(DGW,1,3)," **"
WD2 SET DGDT=$ORDER(^TMP("DGZRAL",$JOB,DGW,DGDT))
IF DGDT=""
GOTO WD1
SET DGNM=0
WD3 SET DGNM=$ORDER(^TMP("DGZRAL",$JOB,DGW,DGDT,DGNM))
IF DGNM=""
GOTO WD2
SET DFN=0
WD4 SET DFN=$ORDER(^TMP("DGZRAL",$JOB,DGW,DGDT,DGNM,DFN))
IF DFN=""
GOTO WD3
+1 SET DGS=^TMP("DGZRAL",$JOB,DGW,DGDT,DGNM,DFN)
+2 SET DGSV=$PIECE(DGS,U)
SET DGDX=$PIECE(DGS,U,2)
SET DGRE=$PIECE(DGS,U,3)
+3 SET DGDSA=$PIECE(DGS,U,4)
SET DGDS=$PIECE(DGS,U,5)
SET DGLST=$PIECE(DGS,U,6)
SET DGA=$PIECE(DGS,U,7)
+4 DO LINE
IF DGSTOP="^"
GOTO END1
GOTO WD4
+5 ;
SERV ;EP;***> admit service order
+1 SET DGSV=0
SV1 SET DGSV=$ORDER(^TMP("DGZRAL",$JOB,DGSV))
IF DGSV=""
GOTO END
SET DGDT=0
+1 IF DGPAGE=0!(DGBDT'=DGEDT)
DO NEWPG^ADGRALP
IF DGSTOP="^"
GOTO END1
+2 IF DGPAGE>0
IF DGBDT=DGEDT
WRITE !!?35,"** ",$EXTRACT(DGSV,1,3)," **"
SV2 SET DGDT=$ORDER(^TMP("DGZRAL",$JOB,DGSV,DGDT))
IF DGDT=""
GOTO SV1
SET DGNM=0
SV3 SET DGNM=$ORDER(^TMP("DGZRAL",$JOB,DGSV,DGDT,DGNM))
IF DGNM=""
GOTO SV2
SET DFN=0
SV4 SET DFN=$ORDER(^TMP("DGZRAL",$JOB,DGSV,DGDT,DGNM,DFN))
IF DFN=""
GOTO SV3
+1 SET DGS=^TMP("DGZRAL",$JOB,DGSV,DGDT,DGNM,DFN)
+2 SET DGW=$PIECE(DGS,U)
SET DGDX=$PIECE(DGS,U,2)
SET DGRE=$PIECE(DGS,U,3)
+3 SET DGDSA=$PIECE(DGS,U,4)
SET DGDS=$PIECE(DGS,U,5)
SET DGLST=$PIECE(DGS,U,6)
SET DGA=$PIECE(DGS,U,7)
+4 DO LINE
IF DGSTOP="^"
GOTO END1
GOTO SV4
+5 ;
+6 ;***> eoj
END IF IOST["C-"
KILL DIR
SET DIR(0)="E"
DO ^DIR
END1 GOTO END1^ADGRALP
+1 ;
LINE ;***> subrtn to print patient data
+1 ;patient name
WRITE !!,$EXTRACT(DGNM,1,20)
+2 ;admit date
WRITE ?32,$EXTRACT(DGDT,4,5)_"/"_$EXTRACT(DGDT,6,7)_"/"_$EXTRACT(DGDT,2,3)
+3 ;admit time
WRITE "@"_$EXTRACT($PIECE(DGDT,".",2)_"000",1,4)
+4 WRITE ?48,$SELECT(DGTYP=2:$EXTRACT(DGSV,1,3),DGTYP=3:$EXTRACT(DGW,1,3),1:"")
+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 ?32,$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 SET DGSVL=$PIECE($GET(^DIC(45.7,+$$TS,0)),U)
+12 SET DGWRD=$PIECE(^DIC(42,$PIECE(^DGPM(+DGA,0),U,6),0),U)
+13 WRITE ?48,$SELECT(DGTYP=2:$EXTRACT(DGSVL,1,3),DGTYP=3:$EXTRACT(DGWRD,1,3),1:"")
+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 ?32,$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 srv
SET DGSRVL=$PIECE(^DIC(45.7,$PIECE(DGDSTR,U,5),0),U)
+22 ;ds procedure
SET DGPROC=$PIECE(DGDSTR,U,2)
+23 WRITE ?48,$SELECT(DGTYP=2:$EXTRACT(DGSV,1,3),1:"")
+24 ;admit proc
WRITE ?53,$EXTRACT(DGPROC,1,25)
End DoDot:1
+25 IF $Y>(IOSL-4)
DO NEWPG^ADGRALP
+26 QUIT
+27 ;
TS() ; -- treating specialty ifn
+1 QUIT $PIECE($GET(^DGPM(+$ORDER(^DGPM("APHY",+DGA,0)),0)),U,9)
