DGJOTP2 ;ALB/MAF - TRANS PROD REPORT CONT. 2 ; AUG 30 1991@1000
;;5.3;Registration;**163,1015**;Aug 13, 1993;Build 21
;
D HEAD F DGJ=0:0 S DGJTDV=$O(^UTILITY("VAS",$J,DGJTDV)) Q:DGJTDV']""!(DGU) S DGJTF=1 D @(DGJTL) Q:DGU
G:DGU QUIT I DGJTLPG'=1,$D(^UTILITY("VAS",$J)) D RET G:DGU QUIT D ^DGJOTP3
QUIT G QUIT^DGJOTP
HD1 W ?65,$S($P(DGJTNODE,"^",2)]""&($D(^VAS(393.3,+$P(DGJTNODE,"^",2),0))):$E($P(^VAS(393.3,$P(DGJTNODE,"^",2),0),"^",1),1,3),1:"")
I DGJTDIR=2 W ?70 S X=$P(DGJTNODE,"^",11) W $S(X=1:"UNDICT",X=2:"DICTAT",X=3:"TRANSC",X=4:"SIGNED",1:"")
S X=$S('$D(^VAS(393,IFN,"DT")):"",$P(^("DT"),"^",1)]"":$P(^("DT"),"^",1),1:"")
W ?77 S:X]"" X=$$FMTE^XLFDT(X,"5DF"),X=$TR(X," ","0") W X
W ?88,$J($P(DGJTDL,"^",2),7)
W ?97,$J($P(DGJTDL,"^",3),7)
W ?106,$J($P(DGJTDL,"^",4),7)
W ?116 S X=$P(DGJTDL,"^",2)+$P(DGJTDL,"^",3)+$P(DGJTDL,"^",4) W $J(X,7) S DGJDYAVG=DGJDYAVG+X
W ?128 S X=$S(X-30'>0:0,1:X-30) W $J(X,4) S DGJ30AVG=DGJ30AVG+X
Q
SET S DGJTDV1=DGJTDV Q
DIV W "* PENDING STATUS - Number of days pending",! Q
Q
DATE S DGJTX=$$FMTE^XLFDT(DGJTDT,"5DF"),DGJTX=$TR(DGJTX," ","0") W DGJTX K DGJTX Q
PHY D:'DGJTFF HDR
F DGJY=0:0 S DGJTPHY=$O(^UTILITY("VAS",$J,DGJTDV,DGJTPHY)) Q:DGJTPHY']""!(DGU) D:DGJTFF RET Q:DGU D:DGJTFF HEAD,HDR D HDR1 S DGJTFF=1 F DGJJ=0:0 S DGJTPT=$O(^UTILITY("VAS",$J,DGJTDV,DGJTPHY,DGJTPT)) Q:DGJTPT']""!(DGU) D PHY1 Q:DGU
Q
PHY1 F DFN=0:0 S DFN=$O(^UTILITY("VAS",$J,DGJTDV,DGJTPHY,DGJTPT,DFN)) Q:'DFN!(DGU) F IFN=0:0 S IFN=$O(^UTILITY("VAS",$J,DGJTDV,DGJTPHY,DGJTPT,DFN,IFN)) Q:'IFN!(DGU) S DGJTDL=^(IFN) D SET I $D(^VAS(393,IFN,0)) D PRT2 Q:DGU D PH^DGJOTP3
Q
SER D:'DGJTFF HDR
F DGJY=0:0 S DGJTSV=$O(^UTILITY("VAS",$J,DGJTDV,DGJTSV)) Q:DGJTSV']""!(DGU) D:DGJTFF RET Q:DGU D:DGJTFF HEAD,HDR D HDR2 S DGJTFF=1 F DGJJ=0:0 S DGJTSP=$O(^UTILITY("VAS",$J,DGJTDV,DGJTSV,DGJTSP)) Q:DGJTSP']""!(DGU) D HDR3,SER1 Q:DGU
Q
SER1 F DGJP=0:0 S DGJTPT=$O(^UTILITY("VAS",$J,DGJTDV,DGJTSV,DGJTSP,DGJTPT)) Q:DGJTPT']""!(DGU) D SER2
Q
SER2 F DFN=0:0 S DFN=$O(^UTILITY("VAS",$J,DGJTDV,DGJTSV,DGJTSP,DGJTPT,DFN)) Q:'DFN!(DGU) F IFN=0:0 S IFN=$O(^UTILITY("VAS",$J,DGJTDV,DGJTSV,DGJTSP,DGJTPT,DFN,IFN)) Q:'IFN!(DGU) S DGJTDL=^(IFN) D SET I $D(^VAS(393,IFN,0)) D PRT2 Q:DGU D SV
Q
PRT2 D RELP Q:DGU S DGJTNODE=^VAS(393,IFN,0)
I DGJTL'="PHY" S DGJTPC=14 S DGJTPHY=$S($P(DGJTNODE,"^",DGJTPC)]""&($D(^VA(200,+$P(DGJTNODE,"^",DGJTPC),0))):$P(^(0),"^",1),1:"NOT SPECIFIED")
I DGJTL="PHY" W !,$E(DGJTPT,1,20)
I DGJTL="SER" W !,$E(DGJTPT,1,16)
D PID^VADPT6 W:DGJTL="SER" ?19 W:DGJTL'="SER" ?23 W VA("BID")
S DGJTDT=$P(DGJTNODE,"^",3) W:DGJTL="SER" ?26 W:DGJTL="PHY" ?31 D DATE
W:DGJTL="SER" ?39 W:DGJTL="PHY" ?44 W $S($P(DGJTNODE,"^",5)]""&($D(^SC(+$P(DGJTNODE,"^",5),0))):$E($P(^SC($P(DGJTNODE,"^",5),0),"^",1),1,12),1:"")
W:DGJTL="SER" ?53,$E(DGJTPHY,1,10) D HD1 Q
HEAD D HEAD^DGJOTP3 Q
RET F X=$Y:1:(IOSL-3) W !
D DIV Q:IOST'?1"C-".E
R ?22,"Enter <RET> to continue or ^ to QUIT ",X:DTIME S:X["^"!('$T) DGU=1 Q:DGU S DGFLAG=1 Q
RELP I $Y+8>IOSL D RET:(IOST?1"C-".E) Q:DGU D HEAD
Q
HDR W !?5,"DIVISION: ",DGJTDV Q
HDR1 W !?6,"PHYSICIAN: ",DGJTPHY Q
HDR2 W !?6,"SERVICE: ",DGJTSV Q
HDR3 W !?7,"SPECIALTY: ",DGJTSP Q
SV D SV^DGJOTP3 Q
DGJOTP2 ;ALB/MAF - TRANS PROD REPORT CONT. 2 ; AUG 30 1991@1000
+1 ;;5.3;Registration;**163,1015**;Aug 13, 1993;Build 21
+2 ;
+3 DO HEAD
FOR DGJ=0:0
SET DGJTDV=$ORDER(^UTILITY("VAS",$JOB,DGJTDV))
IF DGJTDV']""!(DGU)
QUIT
SET DGJTF=1
DO @(DGJTL)
IF DGU
QUIT
+4 IF DGU
GOTO QUIT
IF DGJTLPG'=1
IF $DATA(^UTILITY("VAS",$JOB))
DO RET
IF DGU
GOTO QUIT
DO ^DGJOTP3
QUIT GOTO QUIT^DGJOTP
HD1 WRITE ?65,$SELECT($PIECE(DGJTNODE,"^",2)]""&($DATA(^VAS(393.3,+$PIECE(DGJTNODE,"^",2),0))):$EXTRACT($PIECE(^VAS(393.3,$PIECE(DGJTNODE,"^",2),0),"^",1),1,3),1:"")
+1 IF DGJTDIR=2
WRITE ?70
SET X=$PIECE(DGJTNODE,"^",11)
WRITE $SELECT(X=1:"UNDICT",X=2:"DICTAT",X=3:"TRANSC",X=4:"SIGNED",1:"")
+2 SET X=$SELECT('$DATA(^VAS(393,IFN,"DT")):"",$PIECE(^("DT"),"^",1)]"":$PIECE(^("DT"),"^",1),1:"")
+3 WRITE ?77
IF X]""
SET X=$$FMTE^XLFDT(X,"5DF")
SET X=$TRANSLATE(X," ","0")
WRITE X
+4 WRITE ?88,$JUSTIFY($PIECE(DGJTDL,"^",2),7)
+5 WRITE ?97,$JUSTIFY($PIECE(DGJTDL,"^",3),7)
+6 WRITE ?106,$JUSTIFY($PIECE(DGJTDL,"^",4),7)
+7 WRITE ?116
SET X=$PIECE(DGJTDL,"^",2)+$PIECE(DGJTDL,"^",3)+$PIECE(DGJTDL,"^",4)
WRITE $JUSTIFY(X,7)
SET DGJDYAVG=DGJDYAVG+X
+8 WRITE ?128
SET X=$SELECT(X-30'>0:0,1:X-30)
WRITE $JUSTIFY(X,4)
SET DGJ30AVG=DGJ30AVG+X
+9 QUIT
SET SET DGJTDV1=DGJTDV
QUIT
DIV WRITE "* PENDING STATUS - Number of days pending",!
QUIT
+1 QUIT
DATE SET DGJTX=$$FMTE^XLFDT(DGJTDT,"5DF")
SET DGJTX=$TRANSLATE(DGJTX," ","0")
WRITE DGJTX
KILL DGJTX
QUIT
PHY IF 'DGJTFF
DO HDR
+1 FOR DGJY=0:0
SET DGJTPHY=$ORDER(^UTILITY("VAS",$JOB,DGJTDV,DGJTPHY))
IF DGJTPHY']""!(DGU)
QUIT
IF DGJTFF
DO RET
IF DGU
QUIT
IF DGJTFF
DO HEAD
DO HDR
DO HDR1
SET DGJTFF=1
FOR DGJJ=0:0
SET DGJTPT=$ORDER(^UTILITY("VAS",$JOB,DGJTDV,DGJTPHY,DGJTPT))
IF DGJTPT']""!(DGU)
QUIT
DO PHY1
IF DGU
QUIT
+2 QUIT
PHY1 FOR DFN=0:0
SET DFN=$ORDER(^UTILITY("VAS",$JOB,DGJTDV,DGJTPHY,DGJTPT,DFN))
IF 'DFN!(DGU)
QUIT
FOR IFN=0:0
SET IFN=$ORDER(^UTILITY("VAS",$JOB,DGJTDV,DGJTPHY,DGJTPT,DFN,IFN))
IF 'IFN!(DGU)
QUIT
SET DGJTDL=^(IFN)
DO SET
IF $DATA(^VAS(393,IFN,0))
DO PRT2
IF DGU
QUIT
DO PH^DGJOTP3
+1 QUIT
SER IF 'DGJTFF
DO HDR
+1 FOR DGJY=0:0
SET DGJTSV=$ORDER(^UTILITY("VAS",$JOB,DGJTDV,DGJTSV))
IF DGJTSV']""!(DGU)
QUIT
IF DGJTFF
DO RET
IF DGU
QUIT
IF DGJTFF
DO HEAD
DO HDR
DO HDR2
SET DGJTFF=1
FOR DGJJ=0:0
SET DGJTSP=$ORDER(^UTILITY("VAS",$JOB,DGJTDV,DGJTSV,DGJTSP))
IF DGJTSP']""!(DGU)
QUIT
DO HDR3
DO SER1
IF DGU
QUIT
+2 QUIT
SER1 FOR DGJP=0:0
SET DGJTPT=$ORDER(^UTILITY("VAS",$JOB,DGJTDV,DGJTSV,DGJTSP,DGJTPT))
IF DGJTPT']""!(DGU)
QUIT
DO SER2
+1 QUIT
SER2 FOR DFN=0:0
SET DFN=$ORDER(^UTILITY("VAS",$JOB,DGJTDV,DGJTSV,DGJTSP,DGJTPT,DFN))
IF 'DFN!(DGU)
QUIT
FOR IFN=0:0
SET IFN=$ORDER(^UTILITY("VAS",$JOB,DGJTDV,DGJTSV,DGJTSP,DGJTPT,DFN,IFN))
IF 'IFN!(DGU)
QUIT
SET DGJTDL=^(IFN)
DO SET
IF $DATA(^VAS(393,IFN,0))
DO PRT2
IF DGU
QUIT
DO SV
+1 QUIT
PRT2 DO RELP
IF DGU
QUIT
SET DGJTNODE=^VAS(393,IFN,0)
+1 IF DGJTL'="PHY"
SET DGJTPC=14
SET DGJTPHY=$SELECT($PIECE(DGJTNODE,"^",DGJTPC)]""&($DATA(^VA(200,+$PIECE(DGJTNODE,"^",DGJTPC),0))):$PIECE(^(0),"^",1),1:"NOT SPECIFIED")
+2 IF DGJTL="PHY"
WRITE !,$EXTRACT(DGJTPT,1,20)
+3 IF DGJTL="SER"
WRITE !,$EXTRACT(DGJTPT,1,16)
+4 DO PID^VADPT6
IF DGJTL="SER"
WRITE ?19
IF DGJTL'="SER"
WRITE ?23
WRITE VA("BID")
+5 SET DGJTDT=$PIECE(DGJTNODE,"^",3)
IF DGJTL="SER"
WRITE ?26
IF DGJTL="PHY"
WRITE ?31
DO DATE
+6 IF DGJTL="SER"
WRITE ?39
IF DGJTL="PHY"
WRITE ?44
WRITE $SELECT($PIECE(DGJTNODE,"^",5)]""&($DATA(^SC(+$PIECE(DGJTNODE,"^",5),0))):$EXTRACT($PIECE(^SC($PIECE(DGJTNODE,"^",5),0),"^",1),1,12),1:"")
+7 IF DGJTL="SER"
WRITE ?53,$EXTRACT(DGJTPHY,1,10)
DO HD1
QUIT
HEAD DO HEAD^DGJOTP3
QUIT
RET FOR X=$Y:1:(IOSL-3)
WRITE !
+1 DO DIV
IF IOST'?1"C-".E
QUIT
+2 READ ?22,"Enter <RET> to continue or ^ to QUIT ",X:DTIME
IF X["^"!('$TEST)
SET DGU=1
IF DGU
QUIT
SET DGFLAG=1
QUIT
RELP IF $Y+8>IOSL
IF (IOST?1"C-".E)
DO RET
IF DGU
QUIT
DO HEAD
+1 QUIT
HDR WRITE !?5,"DIVISION: ",DGJTDV
QUIT
HDR1 WRITE !?6,"PHYSICIAN: ",DGJTPHY
QUIT
HDR2 WRITE !?6,"SERVICE: ",DGJTSV
QUIT
HDR3 WRITE !?7,"SPECIALTY: ",DGJTSP
QUIT
SV DO SV^DGJOTP3
QUIT
