81 lines
3.4 KiB
Mathematica
81 lines
3.4 KiB
Mathematica
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
|