- 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)
