DGDIST ;ALB/MRL - DISPOSITION TIME STUDY ; 13 MAY 1987
;;5.3;Registration;;Aug 13, 1993
D:'$D(DT) DT^DICRW S U="^" W !!,*7 S Y=$O(^DPT("ADIS",0)) I Y S (Y,DGEAR)=$P(Y,".",1) X ^DD("DD") W "EARLIEST REGISTRATION ON FILE IS '",Y,"'." G 1
W "NO REGISTRATIONS ON FILE TO START WITH!!" G Q
1 W !! S %DT(0)=-DT,%DT="EAX",%DT("A")="Start with REGISTRATION DATE: " D ^%DT G Q:Y'>0 S DGFR=Y I Y<DGEAR W !?4,"Can't be before earliest registration Date.",*7 G 1
2 S Y=DT X ^DD("DD") S %DT("B")=Y,%DT("A")=" Go To REGISTRATION DATE: " D ^%DT G Q:Y'>0 S DGTO=Y I DGTO<DGFR W !?4,"Can't be before the Start Date.",*7 G 2
3 W !!,"WANT A LISTING OF UNDISPOSITIONED REGISTRATIONS DURING THIS TIMEFRAME" S %=2 D YN^DICN G Q:%=-1 I %>0 S DGU=(%-1) G 4
W !!?4,"As I'm gathering data for this report I may run across some registrations",!?4,"in the timeframe selected which have not yet been dispositioned which I do"
W !?4,"not include in the statistics. If you want a listing of those patients for",!?4,"whom a disposition date/time has not been entered answer YES otherwise",!?4,"answer NO to this prompt." G 3
4 W !!,*7,"Note: This report requires a column width of 132." K %DT S DGPGM="S^DGDIST",DGVAR="DGFR^DGTO^DGU" D ZIS^DGUTQ G Q:POP U IO
S K ^UTILITY($J,"DGT") D:'$D(DT) DT^DICRW S U="^",Y=DT X ^DD("DD") S DGC=0,DGPR="Printed: "_Y I '$D(IOF) S IOP="HOME" D ^%ZIS K IOP
S Y=DGFR X ^DD("DD") S DGHD="Registration/Disposition Time Statistics for "_$S(DGTO>DGFR:"period covering ",1:"")_Y I DGTO>DGFR S Y=DGTO X ^DD("DD") S DGHD=DGHD_" through "_Y
S DGTO=DGTO_".9999",X1=DGFR,X2=-1 D C^%DTC S DGFR=X_".9999" D DIV^DGUTL
F I=0:0 S DGFR=$O(^DPT("ADIS",DGFR)) Q:'DGFR!(DGFR'<DGTO) F DFN=0:0 S DFN=$O(^DPT("ADIS",DGFR,DFN)) Q:'DFN F DGN=0:0 S DGN=$O(^DPT("ADIS",DGFR,DFN,DGN)) Q:'DGN I $D(^DPT(DFN,"DIS",DGN,0)),$P(^(0),"^",2)'=2 S DGD=^(0) D SET
G ^DGDIST1:$D(^UTILITY($J,"DGT")),Q
SET I "^2^4^5^"[("^"_$P(DGD,"^",3)_"^")!($P(DGD,"^",3)'>0) Q
S DGF=$S($L(DGDIV):$P(DGDIV,"^",2),$D(^DG(40.8,+$P(DGD,"^",4),0)):$P(^(0),"^",1),1:"UNSPECIFIED"),DGH=$S($D(^DIC(37,+$P(DGD,"^",7),0)):$P(^(0),"^",1),1:"UNSPECIFIED")
S DGW=$S($D(^DPT(DFN,0)):$P(^(0),"^",1),1:"UNSPECIFIED PT #"_DFN) D PID^VADPT6 S DGS=VA("PID")
S:'$D(^UTILITY($J,"DGT")) ^("DGT")="" S:'$D(^UTILITY($J,"DGT","D",DGF)) ^(DGF)="" S:'$D(^UTILITY($J,"DGT","D",DGF,"H",DGH)) ^(DGH)="" S:'$D(^UTILITY($J,"DGT","D",DGF,"NC")) ^("NC")="" S:'$D(^UTILITY($J,"DGT","NC")) ^("NC")=""
I $P(DGD,"^",7)']"" S $P(^("NC"),"^",1)=$P(^UTILITY($J,"DGT","D",DGF,"NC"),"^",1)+1,$P(^("NC"),"^",1)=$P(^UTILITY($J,"DGT","NC"),"^",1)+1 Q:DGU S Y=$P(DGD,"^",1) X ^DD("DD") S DGC=DGC+1,^UTILITY($J,"DGT","ND",DGW,DGC)=DGS_"^"_DGF_"^"_Y Q
S X=$P(DGD,"^",1),DGX=$P(X,".",2),DGX=$E((DGX_"000"),1,4) D H^%DTC S DGX=%H_","_($E(DGX,1,2)*60*60+($E(DGX,3,4)*60)),X=$P(DGD,"^",6),DGX1=$P(X,".",2),DGX1=$E((DGX1_"000"),1,4)
D H^%DTC S DGX1=%H_","_($E(DGX1,1,2)*60*60+($E(DGX1,3,4)*60)),X=DGX1
S Y=(X-DGX)*86400,X1=$P(X,",",2),X2=$P(DGX,",",2),X3=Y-X2+X1,X=X3\3600,X1=X3#3600\60 S:'X&('X1) X1=1 S DGM=(X*60)+X1,DGP=2,DGY=DGM D N S (DGP,DGY)=1 D N
S DGY=1 I DGM<61 S DGP=3 D N Q ;Disp within 1 hr
I DGM<121 S DGP=4 D N Q ;Disp within 2 hrs
I DGM<481 S DGP=5 D N Q ;Disp within 8 hrs
I DGM<1441 S DGP=6 D N Q ;Disp within 24 hrs
I DGM<2881 S DGP=7 D N Q ;Disp within 48 hrs
I DGM<4321 S DGP=8 D N Q ;Disp within 72 hrs
I DGM<10081 S DGP=9 D N Q ;Disp within 7 dys
I DGM<43201 S DGP=10 D N Q ;Disp within 30 dys
S DGP=11 ;Over 30 dys
N S $P(^("DGT"),"^",DGP)=$P(^UTILITY($J,"DGT"),"^",DGP)+DGY,$P(^(DGF),"^",DGP)=$P(^UTILITY($J,"DGT","D",DGF),"^",DGP)+DGY,$P(^(DGH),"^",DGP)=$P(^UTILITY($J,"DGT","D",DGF,"H",DGH),"^",DGP)+DGY Q
Q W ! K ^UTILITY($J,"DGT"),%,%DT,%H,%Y,D,DFN,DGA,DGC,DGD,DGDIV,DGEAR,DGFR,DGH,DGHD,DGL,DGL1,DGM,DGN,DGP,DGPG,DGPGM,DGPR,DGS,DGTO,DGU,DGU1,DGF,DGVAR,DGW,DGX,DGX1,DGY,I,I1,POP,X,X1,X2,X3,Y,VA,VAERR,Z D CLOSE^DGUTQ Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGDIST 3919 printed Nov 22, 2024@17:52:06 Page 2
DGDIST ;ALB/MRL - DISPOSITION TIME STUDY ; 13 MAY 1987
+1 ;;5.3;Registration;;Aug 13, 1993
+2 if '$DATA(DT)
DO DT^DICRW
SET U="^"
WRITE !!,*7
SET Y=$ORDER(^DPT("ADIS",0))
IF Y
SET (Y,DGEAR)=$PIECE(Y,".",1)
XECUTE ^DD("DD")
WRITE "EARLIEST REGISTRATION ON FILE IS '",Y,"'."
GOTO 1
+3 WRITE "NO REGISTRATIONS ON FILE TO START WITH!!"
GOTO Q
1 WRITE !!
SET %DT(0)=-DT
SET %DT="EAX"
SET %DT("A")="Start with REGISTRATION DATE: "
DO ^%DT
if Y'>0
GOTO Q
SET DGFR=Y
IF Y<DGEAR
WRITE !?4,"Can't be before earliest registration Date.",*7
GOTO 1
2 SET Y=DT
XECUTE ^DD("DD")
SET %DT("B")=Y
SET %DT("A")=" Go To REGISTRATION DATE: "
DO ^%DT
if Y'>0
GOTO Q
SET DGTO=Y
IF DGTO<DGFR
WRITE !?4,"Can't be before the Start Date.",*7
GOTO 2
3 WRITE !!,"WANT A LISTING OF UNDISPOSITIONED REGISTRATIONS DURING THIS TIMEFRAME"
SET %=2
DO YN^DICN
if %=-1
GOTO Q
IF %>0
SET DGU=(%-1)
GOTO 4
+1 WRITE !!?4,"As I'm gathering data for this report I may run across some registrations",!?4,"in the timeframe selected which have not yet been dispositioned which I do"
+2 WRITE !?4,"not include in the statistics. If you want a listing of those patients for",!?4,"whom a disposition date/time has not been entered answer YES otherwise",!?4,"answer NO to this prompt."
GOTO 3
4 WRITE !!,*7,"Note: This report requires a column width of 132."
KILL %DT
SET DGPGM="S^DGDIST"
SET DGVAR="DGFR^DGTO^DGU"
DO ZIS^DGUTQ
if POP
GOTO Q
USE IO
S KILL ^UTILITY($JOB,"DGT")
if '$DATA(DT)
DO DT^DICRW
SET U="^"
SET Y=DT
XECUTE ^DD("DD")
SET DGC=0
SET DGPR="Printed: "_Y
IF '$DATA(IOF)
SET IOP="HOME"
DO ^%ZIS
KILL IOP
+1 SET Y=DGFR
XECUTE ^DD("DD")
SET DGHD="Registration/Disposition Time Statistics for "_$SELECT(DGTO>DGFR:"period covering ",1:"")_Y
IF DGTO>DGFR
SET Y=DGTO
XECUTE ^DD("DD")
SET DGHD=DGHD_" through "_Y
+2 SET DGTO=DGTO_".9999"
SET X1=DGFR
SET X2=-1
DO C^%DTC
SET DGFR=X_".9999"
DO DIV^DGUTL
+3 FOR I=0:0
SET DGFR=$ORDER(^DPT("ADIS",DGFR))
if 'DGFR!(DGFR'<DGTO)
QUIT
FOR DFN=0:0
SET DFN=$ORDER(^DPT("ADIS",DGFR,DFN))
if 'DFN
QUIT
FOR DGN=0:0
SET DGN=$ORDER(^DPT("ADIS",DGFR,DFN,DGN))
if 'DGN
QUIT
IF $DATA(^DPT(DFN,"DIS",DGN,0))
IF $PIECE(^(0),"^",2)'=2
SET DGD=^(0)
DO SET
+4 if $DATA(^UTILITY($JOB,"DGT"))
GOTO ^DGDIST1
GOTO Q
SET IF "^2^4^5^"[("^"_$PIECE(DGD,"^",3)_"^")!($PIECE(DGD,"^",3)'>0)
QUIT
+1 SET DGF=$SELECT($LENGTH(DGDIV):$PIECE(DGDIV,"^",2),$DATA(^DG(40.8,+$PIECE(DGD,"^",4),0)):$PIECE(^(0),"^",1),1:"UNSPECIFIED")
SET DGH=$SELECT($DATA(^DIC(37,+$PIECE(DGD,"^",7),0)):$PIECE(^(0),"^",1),1:"UNSPECIFIED")
+2 SET DGW=$SELECT($DATA(^DPT(DFN,0)):$PIECE(^(0),"^",1),1:"UNSPECIFIED PT #"_DFN)
DO PID^VADPT6
SET DGS=VA("PID")
+3 if '$DATA(^UTILITY($JOB,"DGT"))
SET ^("DGT")=""
if '$DATA(^UTILITY($JOB,"DGT","D",DGF))
SET ^(DGF)=""
if '$DATA(^UTILITY($JOB,"DGT","D",DGF,"H",DGH))
SET ^(DGH)=""
if '$DATA(^UTILITY($JOB,"DGT","D",DGF,"NC"))
SET ^("NC")=""
if '$DATA(^UTILITY($JOB,"DGT","NC"))
SET ^("NC")=""
+4 IF $PIECE(DGD,"^",7)']""
SET $PIECE(^("NC"),"^",1)=$PIECE(^UTILITY($JOB,"DGT","D",DGF,"NC"),"^",1)+1
SET $PIECE(^("NC"),"^",1)=$PIECE(^UTILITY($JOB,"DGT","NC"),"^",1)+1
if DGU
QUIT
SET Y=$PIECE(DGD,"^",1)
XECUTE ^DD("DD")
SET DGC=DGC+1
SET ^UTILITY($JOB,"DGT","ND",DGW,DGC)=DGS_"^"_DGF_"^"_Y
QUIT
+5 SET X=$PIECE(DGD,"^",1)
SET DGX=$PIECE(X,".",2)
SET DGX=$EXTRACT((DGX_"000"),1,4)
DO H^%DTC
SET DGX=%H_","_($EXTRACT(DGX,1,2)*60*60+($EXTRACT(DGX,3,4)*60))
SET X=$PIECE(DGD,"^",6)
SET DGX1=$PIECE(X,".",2)
SET DGX1=$EXTRACT((DGX1_"000"),1,4)
+6 DO H^%DTC
SET DGX1=%H_","_($EXTRACT(DGX1,1,2)*60*60+($EXTRACT(DGX1,3,4)*60))
SET X=DGX1
+7 SET Y=(X-DGX)*86400
SET X1=$PIECE(X,",",2)
SET X2=$PIECE(DGX,",",2)
SET X3=Y-X2+X1
SET X=X3\3600
SET X1=X3#3600\60
if 'X&('X1)
SET X1=1
SET DGM=(X*60)+X1
SET DGP=2
SET DGY=DGM
DO N
SET (DGP,DGY)=1
DO N
+8 ;Disp within 1 hr
SET DGY=1
IF DGM<61
SET DGP=3
DO N
QUIT
+9 ;Disp within 2 hrs
IF DGM<121
SET DGP=4
DO N
QUIT
+10 ;Disp within 8 hrs
IF DGM<481
SET DGP=5
DO N
QUIT
+11 ;Disp within 24 hrs
IF DGM<1441
SET DGP=6
DO N
QUIT
+12 ;Disp within 48 hrs
IF DGM<2881
SET DGP=7
DO N
QUIT
+13 ;Disp within 72 hrs
IF DGM<4321
SET DGP=8
DO N
QUIT
+14 ;Disp within 7 dys
IF DGM<10081
SET DGP=9
DO N
QUIT
+15 ;Disp within 30 dys
IF DGM<43201
SET DGP=10
DO N
QUIT
+16 ;Over 30 dys
SET DGP=11
N SET $PIECE(^("DGT"),"^",DGP)=$PIECE(^UTILITY($JOB,"DGT"),"^",DGP)+DGY
SET $PIECE(^(DGF),"^",DGP)=$PIECE(^UTILITY($JOB,"DGT","D",DGF),"^",DGP)+DGY
SET $PIECE(^(DGH),"^",DGP)=$PIECE(^UTILITY($JOB,"DGT","D",DGF,"H",DGH),"^",DGP)+DGY
QUIT
Q WRITE !
KILL ^UTILITY($JOB,"DGT"),%,%DT,%H,%Y,D,DFN,DGA,DGC,DGD,DGDIV,DGEAR,DGFR,DGH,DGHD,DGL,DGL1,DGM,DGN,DGP,DGPG,DGPGM,DGPR,DGS,DGTO,DGU,DGU1,DGF,DGVAR,DGW,DGX,DGX1,DGY,I,I1,POP,X,X1,X2,X3,Y,VA,VAERR,Z
DO CLOSE^DGUTQ
QUIT
