DGRUGPP ;ALB/BOK/MLI - PRINT PAIS FOR A DATE RANGE ; 25 FEB 87 12:00
;;5.3;Registration;**89**;Aug 13, 1993
DATE K DGW S X="",U="^" R !!,"SORT BY",!," (A)SSESSMENT OR (T)RANSFER/ADMISSION DATE: ASSESSMENT//",X:DTIME S Z="^ASSESSMENT DATE^TRANSFER/ADMISSION" Q:X["^"!('$T) I X="" S X="A" W X
D IN^DGHELP I %=-1 W !!?12,"CHOOSE FROM:",!?12,"A - Sort by Assessment date range",!?12,"T - Sort by Transfer in/Admission date range" G DATE
S DGA=$S(X="A":"AA",1:"AC")
D ASK2^SDDIV G QUIT^DGRUGPP1:Y<0 S %DT("A")="START DATE: ",%DT="AEPX",%DT(0)="-DT" D ^%DT Q:X["^" G:Y<0 DATE S DGSD=Y-.1
S %DT("A")=" END DATE: ",%DT(0)=DGSD+.1 D ^%DT Q:X["^" G:Y<0 DATE S DGED=Y_.9
N ERR S ERR=$$CHOSE^DGRUGU1()
I +ERR<0 G QUIT^DGRUGPP1
S SEL=$P(ERR,"^",2)
S DGPGM="PAIS^DGRUGPP",DGVAR="DGA^DGSD^DGED^DGW#^VAUTD#^DGCL#"
W !!,*7,!!,"THIS REPORT REQUIRES 132 COLUMN OUTPUT"
D ZIS^DGUTQ G:POP QUIT^DGRUGPP1 D PAIS,CLOSE^DGUTQ,QUIT^DGRUGPP1 Q
PAIS U IO S X=132 X ^%ZOSF("RM")
F M=DGSD:0 S M=$O(^DG(45.9,DGA,M)) Q:M'>0!(M>DGED) D
.F DGPT=0:0 S DGPT=$O(^DG(45.9,DGA,M,DGPT)) Q:DGPT'>0 D
..I $D(^DG(45.9,DGPT,"R")) D
...S X=$P(^DG(45.9,DGPT,"R"),"^")
...I $P($G(^DG(45.9,DGPT,0)),"^",6)'=3,$D(DGW),(DGW)!($D(DGW(+X))) D CHECK I $T D SET
...I $P($G(^DG(45.9,DGPT,0)),"^",6)=3,$D(DGCL),(DGCL)!($D(DGCL(+X))) D SET
F X=0:0 S X=$O(^UTILITY($J,"WD",X)) Q:X'>0 D
.F DGPT=0:0 S DGPT=$O(^UTILITY($J,"WD",X,DGPT)) Q:DGPT'>0 D
..F M=0:0 S M=$O(^UTILITY($J,"WD",X,DGPT,M)) Q:M'>0 D EN^DGRUGPP1 S FIRST=""
QT K FIRST,SEL,DGCL,VAUTNI,VAUTSTR,VAUTVB
Q
SET I +X,($P($G(^DG(45.9,DGPT,0)),"^",6)'=3) I $D(DGW),DGW!($D(DGW(+X))) S ^UTILITY($J,"WD",+X,DGPT,M)=$P(^DIC(42,+X,0),U)
I +X,($P($G(^DG(45.9,DGPT,0)),"^",6)=3) I $D(DGCL),DGCL!($D(DGCL(+X))) S ^UTILITY($J,"WD",+X,DGPT,M)=$P(^FBAAV(+X,0),U)
Q
CHECK I X&($P($G(^DG(45.9,DGPT,0)),"^",6)'=3) S DIV=$S('$D(^DIC(42,+X,0)):0,+$P(^(0),U,11):$P(^(0),U,11),1:$O(^DG(40.8,0))) I (VAUTD)!($D(VAUTD(+DIV)))
Q
RUGWARD S DIC="^DIC(42,",VAUTSTR="ward",VAUTVB="DGW",DIC("S")="I $P(^(0),U,3)]"""",""NHI""[$P(^(0),U,3),$S(VAUTD:1,$D(VAUTD(+$P(^(0),U,11))):1,'$P(^(0),U,11)&$D(VAUTD(+$O(^DG(40.8,0)))):1,1:0)"
S VAUTNI=2 D FIRST^VAUTOMA Q
THER S DGHM=$P(DGI,"^",E+16) W ?12,"TIME PER WEEK==> DAYS: ",$P(DGI,"^",E+(E-47)+2)," HOURS: ",$J($S(DGHM']"":"",DGHM<100:0,DGHM<1000:$E(DGHM,1,1),1:+$E(DGHM,1,2)),2)
W " MINUTES: ",$J($S(DGHM']"":"",DGHM<100:+DGHM,DGHM<1000:+$E(DGHM,2,3),1:+$E(DGHM,3,4)),2)
Q
LEV S E(1)=E+(E-47) W E,".",$J($P(^DD(45.9,(E(1)+1),0),U),30),": " W:$P(DGI,U,(E(1)+1))]"" $E($P($P(^DD(45.9,(E(1)+1),0),$P(DGI,U,(E(1)+1))_":",2),";",1),1,27)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRUGPP 2631 printed Oct 16, 2024@18:59:01 Page 2
DGRUGPP ;ALB/BOK/MLI - PRINT PAIS FOR A DATE RANGE ; 25 FEB 87 12:00
+1 ;;5.3;Registration;**89**;Aug 13, 1993
DATE KILL DGW
SET X=""
SET U="^"
READ !!,"SORT BY",!," (A)SSESSMENT OR (T)RANSFER/ADMISSION DATE: ASSESSMENT//",X:DTIME
SET Z="^ASSESSMENT DATE^TRANSFER/ADMISSION"
if X["^"!('$TEST)
QUIT
IF X=""
SET X="A"
WRITE X
+1 DO IN^DGHELP
IF %=-1
WRITE !!?12,"CHOOSE FROM:",!?12,"A - Sort by Assessment date range",!?12,"T - Sort by Transfer in/Admission date range"
GOTO DATE
+2 SET DGA=$SELECT(X="A":"AA",1:"AC")
+3 DO ASK2^SDDIV
if Y<0
GOTO QUIT^DGRUGPP1
SET %DT("A")="START DATE: "
SET %DT="AEPX"
SET %DT(0)="-DT"
DO ^%DT
if X["^"
QUIT
if Y<0
GOTO DATE
SET DGSD=Y-.1
+4 SET %DT("A")=" END DATE: "
SET %DT(0)=DGSD+.1
DO ^%DT
if X["^"
QUIT
if Y<0
GOTO DATE
SET DGED=Y_.9
+5 NEW ERR
SET ERR=$$CHOSE^DGRUGU1()
+6 IF +ERR<0
GOTO QUIT^DGRUGPP1
+7 SET SEL=$PIECE(ERR,"^",2)
+8 SET DGPGM="PAIS^DGRUGPP"
SET DGVAR="DGA^DGSD^DGED^DGW#^VAUTD#^DGCL#"
+9 WRITE !!,*7,!!,"THIS REPORT REQUIRES 132 COLUMN OUTPUT"
+10 DO ZIS^DGUTQ
if POP
GOTO QUIT^DGRUGPP1
DO PAIS
DO CLOSE^DGUTQ
DO QUIT^DGRUGPP1
QUIT
PAIS USE IO
SET X=132
XECUTE ^%ZOSF("RM")
+1 FOR M=DGSD:0
SET M=$ORDER(^DG(45.9,DGA,M))
if M'>0!(M>DGED)
QUIT
Begin DoDot:1
+2 FOR DGPT=0:0
SET DGPT=$ORDER(^DG(45.9,DGA,M,DGPT))
if DGPT'>0
QUIT
Begin DoDot:2
+3 IF $DATA(^DG(45.9,DGPT,"R"))
Begin DoDot:3
+4 SET X=$PIECE(^DG(45.9,DGPT,"R"),"^")
+5 IF $PIECE($GET(^DG(45.9,DGPT,0)),"^",6)'=3
IF $DATA(DGW)
IF (DGW)!($DATA(DGW(+X)))
DO CHECK
IF $TEST
DO SET
+6 IF $PIECE($GET(^DG(45.9,DGPT,0)),"^",6)=3
IF $DATA(DGCL)
IF (DGCL)!($DATA(DGCL(+X)))
DO SET
End DoDot:3
End DoDot:2
End DoDot:1
+7 FOR X=0:0
SET X=$ORDER(^UTILITY($JOB,"WD",X))
if X'>0
QUIT
Begin DoDot:1
+8 FOR DGPT=0:0
SET DGPT=$ORDER(^UTILITY($JOB,"WD",X,DGPT))
if DGPT'>0
QUIT
Begin DoDot:2
+9 FOR M=0:0
SET M=$ORDER(^UTILITY($JOB,"WD",X,DGPT,M))
if M'>0
QUIT
DO EN^DGRUGPP1
SET FIRST=""
End DoDot:2
End DoDot:1
QT KILL FIRST,SEL,DGCL,VAUTNI,VAUTSTR,VAUTVB
+1 QUIT
SET IF +X
IF ($PIECE($GET(^DG(45.9,DGPT,0)),"^",6)'=3)
IF $DATA(DGW)
IF DGW!($DATA(DGW(+X)))
SET ^UTILITY($JOB,"WD",+X,DGPT,M)=$PIECE(^DIC(42,+X,0),U)
+1 IF +X
IF ($PIECE($GET(^DG(45.9,DGPT,0)),"^",6)=3)
IF $DATA(DGCL)
IF DGCL!($DATA(DGCL(+X)))
SET ^UTILITY($JOB,"WD",+X,DGPT,M)=$PIECE(^FBAAV(+X,0),U)
+2 QUIT
CHECK IF X&($PIECE($GET(^DG(45.9,DGPT,0)),"^",6)'=3)
SET DIV=$SELECT('$DATA(^DIC(42,+X,0)):0,+$PIECE(^(0),U,11):$PIECE(^(0),U,11),1:$ORDER(^DG(40.8,0)))
IF (VAUTD)!($DATA(VAUTD(+DIV)))
+1 QUIT
RUGWARD SET DIC="^DIC(42,"
SET VAUTSTR="ward"
SET VAUTVB="DGW"
SET DIC("S")="I $P(^(0),U,3)]"""",""NHI""[$P(^(0),U,3),$S(VAUTD:1,$D(VAUTD(+$P(^(0),U,11))):1,'$P(^(0),U,11)&$D(VAUTD(+$O(^DG(40.8,0)))):1,1:0)"
+1 SET VAUTNI=2
DO FIRST^VAUTOMA
QUIT
THER SET DGHM=$PIECE(DGI,"^",E+16)
WRITE ?12,"TIME PER WEEK==> DAYS: ",$PIECE(DGI,"^",E+(E-47)+2)," HOURS: ",$JUSTIFY($SELECT(DGHM']"":"",DGHM<100:0,DGHM<1000:$EXTRACT(DGHM,1,1),1:+$EXTRACT(DGHM,1,2)),2)
+1 WRITE " MINUTES: ",$JUSTIFY($SELECT(DGHM']"":"",DGHM<100:+DGHM,DGHM<1000:+$EXTRACT(DGHM,2,3),1:+$EXTRACT(DGHM,3,4)),2)
+2 QUIT
LEV SET E(1)=E+(E-47)
WRITE E,".",$JUSTIFY($PIECE(^DD(45.9,(E(1)+1),0),U),30),": "
if $PIECE(DGI,U,(E(1)+1))]""
WRITE $EXTRACT($PIECE($PIECE(^DD(45.9,(E(1)+1),0),$PIECE(DGI,U,(E(1)+1))_":",2),";",1),1,27)
