- ADGLADP ; IHS/ADC/PDW/ENM - ADMISSION 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:DGTYP=2,SERV:DGTYP=3 ;what sort order?
- ;
- DATE ;***> admit date order
- S DGDT=0
- DT1 S DGDT=$O(^TMP("DGZLAD",$J,DGDT)) G END:DGDT="" S DGTM=0
- D NEWPG G END1:DGSTOP=U
- DT2 S DGTM=$O(^TMP("DGZLAD",$J,DGDT,DGTM)) G DT1:DGTM="" S DFN=0
- DT3 S DFN=$O(^TMP("DGZLAD",$J,DGDT,DGTM,DFN)) G DT2:DFN=""
- S DGS=^TMP("DGZLAD",$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("DGZLAD",$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("DGZLAD",$J,DGW,DGDT)) G WD1:DGDT="" S DGNM=0
- WD3 S DGNM=$O(^TMP("DGZLAD",$J,DGW,DGDT,DGNM)) G WD2:DGNM="" S DFN=0
- WD4 S DFN=$O(^TMP("DGZLAD",$J,DGW,DGDT,DGNM,DFN)) G WD3:DFN=""
- S DGS=^TMP("DGZLAD",$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("DGZLAD",$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("DGZLAD",$J,DGSV,DGDT)) G SV1:DGDT="" S DGNM=0
- SV3 S DGNM=$O(^TMP("DGZLAD",$J,DGSV,DGDT,DGNM)) G SV2:DGNM="" S DFN=0
- SV4 S DFN=$O(^TMP("DGZLAD",$J,DGSV,DGDT,DGNM,DFN)) G SV3:DFN=""
- S DGS=^TMP("DGZLAD",$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("DGZLAD") Q
- ;
- ;
- LINE ;***> 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,srv&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(DGSITE)/2,DGSITE S DGTY="ADMISSIONS"
- 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"
- W !,"Patient Name",?24,"HRCN"
- I DGTYP=1 W ?32,"Time",?41,"Srv",?47,"Ward",?57,"Admitting Diagnosis"
- I DGTYP=2 W ?33,"Admit Date",?48,"Srv",?57,"Admitting Diagnosis"
- I DGTYP=3 W ?33,"Admit Date",?47,"Ward",?58,"Admitting Diagnosis"
- W !,DGLINE2
- I DGTYP=1 W !!?25,"** Admitted 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
- ADGLADP ; IHS/ADC/PDW/ENM - ADMISSION 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 ;what sort order?
- IF DGTYP=1
- GOTO DATE
- IF DGTYP=2
- GOTO WARD
- IF DGTYP=3
- GOTO SERV
- +12 ;
- DATE ;***> admit date order
- +1 SET DGDT=0
- DT1 SET DGDT=$ORDER(^TMP("DGZLAD",$JOB,DGDT))
- IF DGDT=""
- GOTO END
- SET DGTM=0
- +1 DO NEWPG
- IF DGSTOP=U
- GOTO END1
- DT2 SET DGTM=$ORDER(^TMP("DGZLAD",$JOB,DGDT,DGTM))
- IF DGTM=""
- GOTO DT1
- SET DFN=0
- DT3 SET DFN=$ORDER(^TMP("DGZLAD",$JOB,DGDT,DGTM,DFN))
- IF DFN=""
- GOTO DT2
- +1 SET DGS=^TMP("DGZLAD",$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("DGZLAD",$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("DGZLAD",$JOB,DGW,DGDT))
- IF DGDT=""
- GOTO WD1
- SET DGNM=0
- WD3 SET DGNM=$ORDER(^TMP("DGZLAD",$JOB,DGW,DGDT,DGNM))
- IF DGNM=""
- GOTO WD2
- SET DFN=0
- WD4 SET DFN=$ORDER(^TMP("DGZLAD",$JOB,DGW,DGDT,DGNM,DFN))
- IF DFN=""
- GOTO WD3
- +1 SET DGS=^TMP("DGZLAD",$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("DGZLAD",$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("DGZLAD",$JOB,DGSV,DGDT))
- IF DGDT=""
- GOTO SV1
- SET DGNM=0
- SV3 SET DGNM=$ORDER(^TMP("DGZLAD",$JOB,DGSV,DGDT,DGNM))
- IF DGNM=""
- GOTO SV2
- SET DFN=0
- SV4 SET DFN=$ORDER(^TMP("DGZLAD",$JOB,DGSV,DGDT,DGNM,DFN))
- IF DFN=""
- GOTO SV3
- +1 SET DGS=^TMP("DGZLAD",$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("DGZLAD")
- QUIT
- +2 ;
- +3 ;
- LINE ;***> 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,srv&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(DGSITE)/2,DGSITE
- SET DGTY="ADMISSIONS"
- +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")_")"
- WRITE !?80-$LENGTH(DGX)/2,DGX
- +8 WRITE !,DGLINE
- IF DGTYP=1
- WRITE !?32,"Admit"
- +9 WRITE !,"Patient Name",?24,"HRCN"
- +10 IF DGTYP=1
- WRITE ?32,"Time",?41,"Srv",?47,"Ward",?57,"Admitting Diagnosis"
- +11 IF DGTYP=2
- WRITE ?33,"Admit Date",?48,"Srv",?57,"Admitting Diagnosis"
- +12 IF DGTYP=3
- WRITE ?33,"Admit Date",?47,"Ward",?58,"Admitting Diagnosis"
- +13 WRITE !,DGLINE2
- +14 IF DGTYP=1
- WRITE !!?25,"** Admitted on ",$EXTRACT(DGDT,4,5)_"/"_$EXTRACT(DGDT,6,7)_"/"_$EXTRACT(DGDT,2,3)," **",!
- +15 IF '$TEST
- IF DGBDT'=DGEDT
- SET DGX="** "_$SELECT(DGTYP=2:DGW,1:DGSV)_" **"
- WRITE !!?80-$LENGTH(DGX)/2,DGX
- +16 QUIT
