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