DGRUGPI ;ALB/BOK/MLI - PRINT PATIENTS WITH INCOMPLETE PAIs ; 15 MAR 87
;;5.3;Registration;**89,97**;Aug 13, 1993
D QUIT D ASK2^SDDIV G:Y<0 QUIT
N ERR S ERR=$$CHOSE^DGRUGU1()
I +ERR<0 G QUIT
S SEL=$P(ERR,"^",2)
W !!,"**** Date Range Selection ****"
DATE S %DT("A")="START DATE: ",%DT="AEPX" D ^%DT G:Y<0 QUIT S DGBDT=Y-.1
S %DT("A")=" END DATE: ",%DT(0)=Y D ^%DT G:Y<0 QUIT S DGEDT=Y_.9
S DGVAR="SEL^DGBDT^DGEDT^DGW#^VAUTD#^DGCL#",DGPGM="START^DGRUGPI" D ZIS^DGUTQ G:POP QUIT D START,CLOSE^DGUTQ Q
;
START W:$E(IOST?1"C-") @IOF
S DGFFL=0 K %DT S X="N",%DT="R" D ^%DT S DGNOW=+Y K X,Y,%DT U IO I '$D(^DG(45.9,"AS",5)) G NOINC
S DGFL=1,DGFL2=0,PAGE=1
F I=0:0 S I=$O(^DG(45.9,"AS",5,I)) Q:+I'>0!(DGFL2) D
.S DGI=^DG(45.9,I,0)
.S W=$S($D(^DG(45.9,I,"R")):$P(^("R"),U),1:0)
.S DGAD=$P($P(DGI,U,2),".")
.S DGTYPE=$P(DGI,U,6) ;assessment purpose
.I DGAD>DGBDT&(DGAD<DGEDT) D SET Q:DGFL2
G:'$D(^UTILITY($J)) NOINC
G:DGFL2 QUIT
S W=""
F Q:DGFL2 D:$E(IOST)="C"&(DGFFL) PAGEND Q:DGFL2 S DGFFL=1 S W=$O(^UTILITY($J,"NOP",W)) Q:(DGFL2)!(W="")!(+W'?.N) D
.S FIRST=1
.F I=0:0 S I=$O(^UTILITY($J,"NOP",+W,I)) Q:+I'>0!(DGFL2) D
..F D=0:0 S D=$O(^UTILITY($J,"NOP",+W,+I,D)) Q:+D'>0!(DGFL2) D
...S DGI=$G(^UTILITY($J,"NOP",W,I,D))
...I FIRST D HEAD S FIRST=0
...D PRT
G:DGFL2 QUIT
QUIT W ! K %DT,^UTILITY($J),D,DFN,DGAD,DGBDT,DGEDT,DGFFL,DGFL,DGFL2,DGI,DGNOW
K DGPGM,DGVAR,DGW,DIV,E,I,POP,W,X,Y,DGCL,VAUTD,PAGE,DGTYPE,FIRST
Q
;
SET Q:'$D(DGW)&('$D(DGCL))
I DGTYPE'=3 I SEL="B"!(SEL="R") I 'VAUTD S DIV=+$S(+$P($G(^DIC(42,+W,0)),U,11):$P(^(0),U,11),1:$O(^DG(40.8,0))) I '$D(VAUTD(+DIV)) Q
I DGTYPE=3 S DIV=0
I SEL="C" Q:'$D(DGCL(+W))&(DGCL'=1) I (DGTYPE=3) S ^UTILITY($J,"NOP",+W,I,$P(DGI,U,2))=$P(DGI,U,1,7)
I SEL="R" Q:'$D(DGW(+W))&(DGW'=1) I (DGTYPE'=3) S ^UTILITY($J,"NOP",+W,I,$P(DGI,U,2))=$P(DGI,U,1,7)
I SEL="B" S:W="" W=0 D
.I DGTYPE=3 I DGCL=1!($D(DGCL(+W))) S ^UTILITY($J,"NOP",+W,I,$P(DGI,U,2))=$P(DGI,U,1,7)
.I DGTYPE'=3 I DGW=1!($D(DGW(+W))) S ^UTILITY($J,"NOP",+W,I,$P(DGI,U,2))=$P(DGI,U,1,7)
Q
;
PRT I $Y'<(IOSL-2) D PAGEND:$E(IOST)="C" Q:DGFL2 D HEAD
Q:DGFL2
S DFN=+DGI W !,$E($P(^DPT(+DGI,0),U),1,25),?27,$P(DGI,U,3),?42 S Y=$P($P(DGI,U,7),".") D DT^DIQ W ?62,$S($P(DGI,U,6)=1:"ADMISSION/TRANSFER",$P(DGI,U,6)=2:"SEMI-ANNUAL CENSUS",$P(DGI,U,6)=3:"CONTRACT NURSING HOME")
Q
HEAD I PAGE>1!($E(IOST)="C") W @IOF
S PAGE=PAGE+1
W !!?20,"INCOMPLETE PATIENT ASSESSMENT INSTRUMENTS"
W !?20 D DATES
I '+W D NOWD
I $P(DGI,"^",6)'=3 W !!,$P($G(^DIC(42,+W,0)),U)
I $P(DGI,"^",6)=3 W !!,$P($G(^FBAAV(+W,0)),U)
W !!?45,"DATE OF",?66,"ASSESSMENT",!,"NAME",?30,"SSN",?40,"ADMISSION/TRANSFER",?68,"PURPOSE"
K E S $P(E,"=",81)="" W !,E
Q
NOWD W !!,"No location listed in Patient Assessment File for:" S DGFL=0 Q
PAGEND W !,?29,"HIT <RETURN> TO CONTINUE" R X:DTIME S:X["^"!('$T) DGFL2=1 S DGFL=1 Q:X[""
Q:DGFL2
G PAGEND
NOINC W @IOF,!!,"INCOMPLETE PATIENT ASSESSMENTS",!!!!,"THERE ARE NO PATIENTS WITH THE STATUS OF INCOMPLETE" W ! D DATES,LOC G QUIT
DATES W !?20,"FOR DATE RANGE: " S Y=DGBDT+.1 D DT^DIQ W "-" S Y=DGEDT-.9 D DT^DIQ W !?20," DATE PRINTED: " S Y=DGNOW D DT^DIQ
Q
LOC ;
N CNT
W !!?10,"FOR LOCATIONS: "
I $D(DGCL),DGCL=1 W "ALL Contract Nursing Homes "
I $D(DGW),DGW=1 W "ALL Wards"
I $D(DGCL),DGCL'=1 D
.S CNT=0
.F S CNT=$O(DGCL(CNT)) Q:CNT="" D
..W !?20,$P($G(DGCL(CNT)),"^")
I $D(DGW),DGW'=1 D
.S CNT=0
.F S CNT=$O(DGW(CNT)) Q:CNT="" D
..W !?20,$P($G(DGW(CNT)),"^")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRUGPI 3528 printed Oct 16, 2024@18:59 Page 2
DGRUGPI ;ALB/BOK/MLI - PRINT PATIENTS WITH INCOMPLETE PAIs ; 15 MAR 87
+1 ;;5.3;Registration;**89,97**;Aug 13, 1993
+2 DO QUIT
DO ASK2^SDDIV
if Y<0
GOTO QUIT
+3 NEW ERR
SET ERR=$$CHOSE^DGRUGU1()
+4 IF +ERR<0
GOTO QUIT
+5 SET SEL=$PIECE(ERR,"^",2)
+6 WRITE !!,"**** Date Range Selection ****"
DATE SET %DT("A")="START DATE: "
SET %DT="AEPX"
DO ^%DT
if Y<0
GOTO QUIT
SET DGBDT=Y-.1
+1 SET %DT("A")=" END DATE: "
SET %DT(0)=Y
DO ^%DT
if Y<0
GOTO QUIT
SET DGEDT=Y_.9
+2 SET DGVAR="SEL^DGBDT^DGEDT^DGW#^VAUTD#^DGCL#"
SET DGPGM="START^DGRUGPI"
DO ZIS^DGUTQ
if POP
GOTO QUIT
DO START
DO CLOSE^DGUTQ
QUIT
+3 ;
START if $EXTRACT(IOST?1"C-")
WRITE @IOF
+1 SET DGFFL=0
KILL %DT
SET X="N"
SET %DT="R"
DO ^%DT
SET DGNOW=+Y
KILL X,Y,%DT
USE IO
IF '$DATA(^DG(45.9,"AS",5))
GOTO NOINC
+2 SET DGFL=1
SET DGFL2=0
SET PAGE=1
+3 FOR I=0:0
SET I=$ORDER(^DG(45.9,"AS",5,I))
if +I'>0!(DGFL2)
QUIT
Begin DoDot:1
+4 SET DGI=^DG(45.9,I,0)
+5 SET W=$SELECT($DATA(^DG(45.9,I,"R")):$PIECE(^("R"),U),1:0)
+6 SET DGAD=$PIECE($PIECE(DGI,U,2),".")
+7 ;assessment purpose
SET DGTYPE=$PIECE(DGI,U,6)
+8 IF DGAD>DGBDT&(DGAD<DGEDT)
DO SET
if DGFL2
QUIT
End DoDot:1
+9 if '$DATA(^UTILITY($JOB))
GOTO NOINC
+10 if DGFL2
GOTO QUIT
+11 SET W=""
+12 FOR
if DGFL2
QUIT
if $EXTRACT(IOST)="C"&(DGFFL)
DO PAGEND
if DGFL2
QUIT
SET DGFFL=1
SET W=$ORDER(^UTILITY($JOB,"NOP",W))
if (DGFL2)!(W="")!(+W'?.N)
QUIT
Begin DoDot:1
+13 SET FIRST=1
+14 FOR I=0:0
SET I=$ORDER(^UTILITY($JOB,"NOP",+W,I))
if +I'>0!(DGFL2)
QUIT
Begin DoDot:2
+15 FOR D=0:0
SET D=$ORDER(^UTILITY($JOB,"NOP",+W,+I,D))
if +D'>0!(DGFL2)
QUIT
Begin DoDot:3
+16 SET DGI=$GET(^UTILITY($JOB,"NOP",W,I,D))
+17 IF FIRST
DO HEAD
SET FIRST=0
+18 DO PRT
End DoDot:3
End DoDot:2
End DoDot:1
+19 if DGFL2
GOTO QUIT
QUIT WRITE !
KILL %DT,^UTILITY($JOB),D,DFN,DGAD,DGBDT,DGEDT,DGFFL,DGFL,DGFL2,DGI,DGNOW
+1 KILL DGPGM,DGVAR,DGW,DIV,E,I,POP,W,X,Y,DGCL,VAUTD,PAGE,DGTYPE,FIRST
+2 QUIT
+3 ;
SET if '$DATA(DGW)&('$DATA(DGCL))
QUIT
+1 IF DGTYPE'=3
IF SEL="B"!(SEL="R")
IF 'VAUTD
SET DIV=+$SELECT(+$PIECE($GET(^DIC(42,+W,0)),U,11):$PIECE(^(0),U,11),1:$ORDER(^DG(40.8,0)))
IF '$DATA(VAUTD(+DIV))
QUIT
+2 IF DGTYPE=3
SET DIV=0
+3 IF SEL="C"
if '$DATA(DGCL(+W))&(DGCL'=1)
QUIT
IF (DGTYPE=3)
SET ^UTILITY($JOB,"NOP",+W,I,$PIECE(DGI,U,2))=$PIECE(DGI,U,1,7)
+4 IF SEL="R"
if '$DATA(DGW(+W))&(DGW'=1)
QUIT
IF (DGTYPE'=3)
SET ^UTILITY($JOB,"NOP",+W,I,$PIECE(DGI,U,2))=$PIECE(DGI,U,1,7)
+5 IF SEL="B"
if W=""
SET W=0
Begin DoDot:1
+6 IF DGTYPE=3
IF DGCL=1!($DATA(DGCL(+W)))
SET ^UTILITY($JOB,"NOP",+W,I,$PIECE(DGI,U,2))=$PIECE(DGI,U,1,7)
+7 IF DGTYPE'=3
IF DGW=1!($DATA(DGW(+W)))
SET ^UTILITY($JOB,"NOP",+W,I,$PIECE(DGI,U,2))=$PIECE(DGI,U,1,7)
End DoDot:1
+8 QUIT
+9 ;
PRT IF $Y'<(IOSL-2)
if $EXTRACT(IOST)="C"
DO PAGEND
if DGFL2
QUIT
DO HEAD
+1 if DGFL2
QUIT
+2 SET DFN=+DGI
WRITE !,$EXTRACT($PIECE(^DPT(+DGI,0),U),1,25),?27,$PIECE(DGI,U,3),?42
SET Y=$PIECE($PIECE(DGI,U,7),".")
DO DT^DIQ
WRITE ?62,$SELECT($PIECE(DGI,U,6)=1:"ADMISSION/TRANSFER",$PIECE(DGI,U,6)=2:"SEMI-ANNUAL CENSUS",$PIECE(DGI,U,6)=3:"CONTRACT NURSING HOME")
+3 QUIT
HEAD IF PAGE>1!($EXTRACT(IOST)="C")
WRITE @IOF
+1 SET PAGE=PAGE+1
+2 WRITE !!?20,"INCOMPLETE PATIENT ASSESSMENT INSTRUMENTS"
+3 WRITE !?20
DO DATES
+4 IF '+W
DO NOWD
+5 IF $PIECE(DGI,"^",6)'=3
WRITE !!,$PIECE($GET(^DIC(42,+W,0)),U)
+6 IF $PIECE(DGI,"^",6)=3
WRITE !!,$PIECE($GET(^FBAAV(+W,0)),U)
+7 WRITE !!?45,"DATE OF",?66,"ASSESSMENT",!,"NAME",?30,"SSN",?40,"ADMISSION/TRANSFER",?68,"PURPOSE"
+8 KILL E
SET $PIECE(E,"=",81)=""
WRITE !,E
+9 QUIT
NOWD WRITE !!,"No location listed in Patient Assessment File for:"
SET DGFL=0
QUIT
PAGEND WRITE !,?29,"HIT <RETURN> TO CONTINUE"
READ X:DTIME
if X["^"!('$TEST)
SET DGFL2=1
SET DGFL=1
if X[""
QUIT
+1 if DGFL2
QUIT
+2 GOTO PAGEND
NOINC WRITE @IOF,!!,"INCOMPLETE PATIENT ASSESSMENTS",!!!!,"THERE ARE NO PATIENTS WITH THE STATUS OF INCOMPLETE"
WRITE !
DO DATES
DO LOC
GOTO QUIT
DATES WRITE !?20,"FOR DATE RANGE: "
SET Y=DGBDT+.1
DO DT^DIQ
WRITE "-"
SET Y=DGEDT-.9
DO DT^DIQ
WRITE !?20," DATE PRINTED: "
SET Y=DGNOW
DO DT^DIQ
+1 QUIT
LOC ;
+1 NEW CNT
+2 WRITE !!?10,"FOR LOCATIONS: "
+3 IF $DATA(DGCL)
IF DGCL=1
WRITE "ALL Contract Nursing Homes "
+4 IF $DATA(DGW)
IF DGW=1
WRITE "ALL Wards"
+5 IF $DATA(DGCL)
IF DGCL'=1
Begin DoDot:1
+6 SET CNT=0
+7 FOR
SET CNT=$ORDER(DGCL(CNT))
if CNT=""
QUIT
Begin DoDot:2
+8 WRITE !?20,$PIECE($GET(DGCL(CNT)),"^")
End DoDot:2
End DoDot:1
+9 IF $DATA(DGW)
IF DGW'=1
Begin DoDot:1
+10 SET CNT=0
+11 FOR
SET CNT=$ORDER(DGW(CNT))
if CNT=""
QUIT
Begin DoDot:2
+12 WRITE !?20,$PIECE($GET(DGW(CNT)),"^")
End DoDot:2
End DoDot:1
+13 QUIT
