source: FOIAVistA/trunk/r/SOCIAL_WORK-SOW-SWBH-SWFG/SOWKRCH.m@ 632

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

initial load of FOIAVistA 6/30/08 version

File size: 4.7 KB
Line 
1SOWKRCH ;B'HAM ISC/SAB-Routine to print RCH AMIS 256 report ; 24 Feb 93 / 2:32 PM [ 09/29/94 8:18 AM ]
2 ;;3.0; Social Work ;**34,53**;27 Apr 93
3 K ^TMP($J),PLP I '$D(^SOWK(650.1,1)) W *7,!,"PLEASE ENTER SITE PARAMETERS !!",! G CLOS
4BEG W ! S %DT="AEXP",%DT("A")="ALL CASES STARTING FROM: " D ^%DT G:"^"[X CLOS G:Y'>0 BEG S SB1=Y X ^DD("DD") S SBA=Y
5END W ! S %DT("A")="ALL CASES ENDING: " D ^%DT G:"^"[X CLOS G:Y'>0 END S SE1=Y X ^DD("DD") S SEA=Y
6 D DEV I $D(ZTSK)!($D(OUT))!(POP) K ZTSK G CLOS
7ENQ F SOWK=0:0 S SOWK=$O(^SOWK(650.1,SOWK)) Q:'SOWK!($G(OUT1)=1) D START K ^TMP($J)
8CLOS W:$E(IOST)'["C" @IOF D ^%ZISC
9 K ^TMP($J),PL,II,HM,OUT,AB,ABB,SBB,SW,SWW,O,OUT1,P,R,SB,SB1,SE1,SWB,SWE,SWLT,SP,D,H,J,IOP,POP,SOWK,DIS,DFN,LCN,SWTHT D KVA^VADPT
10 K LC,SOWKFD,SOWKFB,SOWKDIV,SWTOT,SWPTO,SWLT,SWPLT,SWVT,SWPV,%DT,AG,C,EE,F,G,I,L,M,N,S D:$D(ZTSK) KILL^%ZTLOAD
11 K PCH,E,V,B,K,SWPLT,SWPLTO,SWPV,SWTOT,SWVT,T,X,X1,X2,Y,Z,ST,STT,Q,SBA,SEA,CN,RCH,SOWKAB,PLP
12 Q
13START F T=1:1:10 S (LP(T),LPP(T))=0
14 F N=1:1:3 S (NB(N),NBB(N))=0
15 F N=0:0 S N=$O(^SOWK(650.1,1,2,N)) Q:'N S (ST(N),STT(N))=0
16 S (SWTHT,SWPT,SWPU,SWPP,SWTT,SWPTT,SWTOT,SWPTO,SWLT,SWPLT,SWPLTO,SWVT,SWPV)=0
17 F T=0:1:4 S (AB(T),ABB(T),SB(T),SBB(T),SW(T),SWW(T))=0
18 K T S SOWKDIV=SOWK
19 U IO W:$Y @IOF W ?20,"RCH AMIS 256 FROM ",SBA," TO ",SEA
20 W !,"TOTAL FOR "_$P(^SOWK(650.1,SOWK,0),"^"),!!
21 ;CALCULATE TOTALS
22 S SOWKAB="ALL" D CAL,PRINT I $G(OUT1)'=1 D ^SOWKRCH1 I $G(OUT1)'=1 S SOWKFD=SB1,SOWKFB=SE1 D ENQ^SOWKPAOD,ENQ^SOWKDSC
23 Q
24CAL F II=0:0 S II=$O(^SOWK(650,II)) Q:'II S B=^SOWK(650,II,0) I B,$P(^SOWK(651,$P(B,"^",13),0),"^",6)="R",$P(B,"^",5)=SOWK S (P,DFN)=$P(B,"^",8),LC=$P(B,"^",23) D DEM^VADPT,SEA
25 Q
26REM S:+LC NB(LC)=NB(LC)+1 I $P(B,"^",14) S ST($P(B,"^",14))=ST($P(B,"^",14))+1
27 Q
28SEA I $D(^SOWK(655,P,4)) S PL=^SOWK(655,P,0) F HM=0:0 S HM=$O(^SOWK(655,P,4,HM)) Q:'HM I $P(^SOWK(655,P,4,HM,0),"^",5)=II S PCH=^(0),RCH=$P(^(0),"^") D SE1
29 Q
30SE1 S AG=+VADM(4),X=$S(AG<29:0,AG'<30&(AG'>44):1,AG'<45&(AG'>59):2,AG'<60&(AG'>79):3,1:4)
31 I $P(PL,"^",2)'<SB1,$P(PL,"^",2)'>SE1,'$P(PCH,"^",6),'$O(^TMP($J,P,0)) S ^TMP($J,P,II)="" S SW(X)=SW(X)+1
32 I $P(PCH,"^",4)'<SB1,$P(PCH,"^",4)'>SE1,'$P(PCH,"^",6) S SB(X)=SB(X)+1
33 D REQ
34 I $P(PL,"^",2)'<SB1,$P(PL,"^",2)'>SE1,'$P(PCH,"^",6) S LP($P(B,"^",11))=$G(LP($P(B,"^",11)))+1 I $O(^TMP($J,P,0)),$O(^TMP($J,P,0))'=II S CN=$O(^TMP($J,P,0)),LP($P(^SOWK(650,CN,0),"^",11))=$G(LP($P(^SOWK(650,CN,0),"^",11)))-1
35 Q
36REQ ;
37 I $P(PCH,"^",2)'<SB1,'$P(PCH,"^",4),$P(PCH,"^",2)'>SE1 S AB(X)=$G(AB(X))+1 D REM Q
38 I $P(PCH,"^",2)'<SB1,$P(PCH,"^",2)'>SE1,$P(PCH,"^",4)>SE1 S AB(X)=$G(AB(X))+1 D REM Q
39 I $P(PCH,"^",2)<SB1,$P(PCH,"^",4)>SE1 S AB(X)=$G(AB(X))+1 D REM Q
40 I $P(PCH,"^",2)<SB1,'$P(PCH,"^",4) S AB(X)=$G(AB(X))+1 D REM
41 Q
42DEV W !!,"WARNING !!!",!?5,"This report is formatted for 132 columns and will be",!?5,"difficult to read if printed to the screen.",!
43 K ZTSK,%ZIS,IOP,OUT S SOWKION=ION,%ZIS="QM",%ZIS("B")="" D ^%ZIS K %ZIS I POP S IOP=SOWKION D ^%ZIS K IOP,SOWKION S POP=1 Q
44 K SOWKION I $D(IO("Q")) S ZTDESC="RESIDENTIAL CARE HOME AMIS REPORT",ZTRTN="ENQ^SOWKRCH" F G="SE1","SB1","SBA","SEA" S:$D(@G) ZTSAVE(G)=""
45 I K IO("Q") D ^%ZTLOAD I '$D(ZTSK) S OUT=1 W:$E(IOST)'["C" @IOF D ^%ZISC K %DT,SB1,SE1,G,SEA,SBA Q
46 I $D(ZTSK) W !!,"Task Queued to Print",! K G,SEA,SBA,%DT,SB1,SE1
47 Q
48PRINT ;PRINT TOTALS
49 F T=0:1:4 S SWTOT=SW(T)+SWTOT
50 F T=0:1:4 S:SWTOT SWW(T)=(SW(T)/SWTOT)*100,SWPTO=SWW(T)+SWPTO
51 F T=0:1:4 S SWLT=SB(T)+SWLT,SWVT=AB(T)+SWVT
52 F T=0:1:4 S:SWLT SBB(T)=(SB(T)/SWLT)*100,SWPLTO=SBB(T)+SWPLTO
53 F T=0:1:4 S:SWVT ABB(T)=(AB(T)/SWVT)*100,SWPV=ABB(T)+SWPV
54 F X=1:1:3 D Q:$G(OUT1)=1
55 .U IO W !!?10,$S(X=1:"CASES OPENED DURING QUARTER",X=2:"CASES CLOSED DURING QUARTER",1:"TOTAL CASES TREATED")
56 .W !?4,"LESS",?11,"30",?17,"45",?23,"60",?29,"80",!?4,"THAN",?11,"TO",?17,"TO",?23,"TO",?29,"AND",!?5,"29",?11,"44",?17,"59",?23,"79",?29,"UP",?35,"TOTAL",! F F=1:1:41 W "-"
57 .I X=1 D
58 ..W !,"NO.",?5,$J(SW(0),3,0),?11,$J(SW(1),3,0),?17,$J(SW(2),3,0),?23,$J(SW(3),3,0),?29,$J(SW(4),3,0),?35,$J(SWTOT,3,0)
59 ..W !,"%",?5,$J(SWW(0),3,0),?11,$J(SWW(1),3,0),?17,$J(SWW(2),3,0),?23,$J(SWW(3),3,0),?29,$J(SWW(4),3,0),?35,$J(SWPTO,3,0),!
60 .I X=2 D
61 ..W !,"NO.",?5,$J(SB(0),3,0),?11,$J(SB(1),3,0),?17,$J(SB(2),3,0),?23,$J(SB(3),3,0),?29,$J(SB(4),3,0),?35,$J(SWLT,3,0)
62 ..W !,"%",?5,$J(SBB(0),3,0),?11,$J(SBB(1),3,0),?17,$J(SBB(2),3,0),?23,$J(SBB(3),3,0),?29,$J(SBB(4),3,0),?35,$J(SWPLTO,3,0),!
63 .I X=3 D
64 ..W !,"NO.",?5,$J(AB(0),3,0),?11,$J(AB(1),3,0),?17,$J(AB(2),3,0),?23,$J(AB(3),3,0),?29,$J(AB(4),3,0),?35,$J(SWVT,3,0)
65 ..W !,"%",?5,$J(ABB(0),3,0),?11,$J(ABB(1),3,0),?17,$J(ABB(2),3,0),?23,$J(ABB(3),3,0),?29,$J(ABB(4),3,0),?35,$J(SWPV,3,0),!
66 .F F=1:1:41 W "-"
67 .D:($Y+10)>IOSL CHK
68 W !!!
69 Q
70CHK ;
71 N SWXX
72 I $E(IOST)["C" R !,"Press <RETURN> to continue: ",SWXX:DTIME I SWXX["^" S OUT1=1 W @IOF Q
73 W @IOF
74 Q
Note: See TracBrowser for help on using the repository browser.