source: FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUGPI.m@ 1606

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