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

Last change on this file since 724 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.4 KB
Line 
1DGRUGPI ;ALB/BOK/MLI - PRINT PATIENTS WITH INCOMPLETE PAIs ; 15 MAR 87
2 ;;5.3;Registration;**89,97**;Aug 13, 1993
3 D QUIT D ASK2^SDDIV G:Y<0 QUIT
4 N ERR S ERR=$$CHOSE^DGRUGU1()
5 I +ERR<0 G QUIT
6 S SEL=$P(ERR,"^",2)
7 W !!,"**** Date Range Selection ****"
8DATE S %DT("A")="START DATE: ",%DT="AEPX" D ^%DT G:Y<0 QUIT S DGBDT=Y-.1
9 S %DT("A")=" END DATE: ",%DT(0)=Y D ^%DT G:Y<0 QUIT S DGEDT=Y_.9
10 S DGVAR="SEL^DGBDT^DGEDT^DGW#^VAUTD#^DGCL#",DGPGM="START^DGRUGPI" D ZIS^DGUTQ G:POP QUIT D START,CLOSE^DGUTQ Q
11 ;
12START W:$E(IOST?1"C-") @IOF
13 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
14 S DGFL=1,DGFL2=0,PAGE=1
15 F I=0:0 S I=$O(^DG(45.9,"AS",5,I)) Q:+I'>0!(DGFL2) D
16 .S DGI=^DG(45.9,I,0)
17 .S W=$S($D(^DG(45.9,I,"R")):$P(^("R"),U),1:0)
18 .S DGAD=$P($P(DGI,U,2),".")
19 .S DGTYPE=$P(DGI,U,6) ;assessment purpose
20 .I DGAD>DGBDT&(DGAD<DGEDT) D SET Q:DGFL2
21 G:'$D(^UTILITY($J)) NOINC
22 G:DGFL2 QUIT
23 S W=""
24 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
25 .S FIRST=1
26 .F I=0:0 S I=$O(^UTILITY($J,"NOP",+W,I)) Q:+I'>0!(DGFL2) D
27 ..F D=0:0 S D=$O(^UTILITY($J,"NOP",+W,+I,D)) Q:+D'>0!(DGFL2) D
28 ...S DGI=$G(^UTILITY($J,"NOP",W,I,D))
29 ...I FIRST D HEAD S FIRST=0
30 ...D PRT
31 G:DGFL2 QUIT
32QUIT W ! K %DT,^UTILITY($J),D,DFN,DGAD,DGBDT,DGEDT,DGFFL,DGFL,DGFL2,DGI,DGNOW
33 K DGPGM,DGVAR,DGW,DIV,E,I,POP,W,X,Y,DGCL,VAUTD,PAGE,DGTYPE,FIRST
34 Q
35 ;
36SET Q:'$D(DGW)&('$D(DGCL))
37 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
38 I DGTYPE=3 S DIV=0
39 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)
40 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)
41 I SEL="B" S:W="" W=0 D
42 .I DGTYPE=3 I DGCL=1!($D(DGCL(+W))) S ^UTILITY($J,"NOP",+W,I,$P(DGI,U,2))=$P(DGI,U,1,7)
43 .I DGTYPE'=3 I DGW=1!($D(DGW(+W))) S ^UTILITY($J,"NOP",+W,I,$P(DGI,U,2))=$P(DGI,U,1,7)
44 Q
45 ;
46PRT I $Y'<(IOSL-2) D PAGEND:$E(IOST)="C" Q:DGFL2 D HEAD
47 Q:DGFL2
48 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")
49 Q
50HEAD I PAGE>1!($E(IOST)="C") W @IOF
51 S PAGE=PAGE+1
52 W !!?20,"INCOMPLETE PATIENT ASSESSMENT INSTRUMENTS"
53 W !?20 D DATES
54 I '+W D NOWD
55 I $P(DGI,"^",6)'=3 W !!,$P($G(^DIC(42,+W,0)),U)
56 I $P(DGI,"^",6)=3 W !!,$P($G(^FBAAV(+W,0)),U)
57 W !!?45,"DATE OF",?66,"ASSESSMENT",!,"NAME",?30,"SSN",?40,"ADMISSION/TRANSFER",?68,"PURPOSE"
58 K E S $P(E,"=",81)="" W !,E
59 Q
60NOWD W !!,"No location listed in Patient Assessment File for:" S DGFL=0 Q
61PAGEND W !,?29,"HIT <RETURN> TO CONTINUE" R X:DTIME S:X["^"!('$T) DGFL2=1 S DGFL=1 Q:X[""
62 Q:DGFL2
63 G PAGEND
64NOINC W @IOF,!!,"INCOMPLETE PATIENT ASSESSMENTS",!!!!,"THERE ARE NO PATIENTS WITH THE STATUS OF INCOMPLETE" W ! D DATES,LOC G QUIT
65DATES 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
66 Q
67LOC ;
68 N CNT
69 W !!?10,"FOR LOCATIONS: "
70 I $D(DGCL),DGCL=1 W "ALL Contract Nursing Homes "
71 I $D(DGW),DGW=1 W "ALL Wards"
72 I $D(DGCL),DGCL'=1 D
73 .S CNT=0
74 .F S CNT=$O(DGCL(CNT)) Q:CNT="" D
75 ..W !?20,$P($G(DGCL(CNT)),"^")
76 I $D(DGW),DGW'=1 D
77 .S CNT=0
78 .F S CNT=$O(DGW(CNT)) Q:CNT="" D
79 ..W !?20,$P($G(DGW(CNT)),"^")
80 Q
Note: See TracBrowser for help on using the repository browser.