source: FOIAVistA/trunk/r/INCIDENT_REPORTING-QAN/QANQTOT.m@ 674

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

initial load of FOIAVistA 6/30/08 version
File size: 4.6 KB
Line 
1QANQTOT ;GJC/HISC-QUARTERLY REPORT OF INVESTIGATIONS (REGIONAL) ;9/3/93 12:17
2 ;;2.0;Incident Reporting;**21,25**;08/07/1992
3 ;
4 I $G(DUZ)']"" D Q
5 . W !!?12,*7,"This option CANNOT properly identify you, exiting."
6 . D EXIT
7 S (QANMSSG,QANXIT,QAQQUIT)=0
8 D QUART I QAQQUIT D EXIT Q
9 D CHECK ;Data for quarter exists OR global lock times out, exiting!
10 I QANXIT D EXIT Q
11 S QANBEG=QUBEG(QU)-.0000001,QANEND=QUEND(QU)_".9999999"
12 S QANDATE=QUBEG(QU),QANTODAY=DT
13 F QANDT=QANBEG:0 S QANDT=$O(^QA(742.4,"BDT",QANDT)) Q:(QANDT>QANEND)!(QANDT'>0) D
14 . F QANIEN=0:0 S QANIEN=$O(^QA(742.4,"BDT",QANDT,QANIEN)) Q:QANIEN'>0 D:'$D(^QA(742.4,"ACS",2,QANIEN)) PATFND
15 I '$D(^UTILITY($J,"QAN IR/PAT")) D Q
16 . W !!,*7,"No data found for the ",$S($G(QAQ2HED)]"":QAQ2HED,1:QUART),", exiting.",*7,!!
17 . D EXIT
18 F QANIEN=0:0 S QANIEN=$O(^UTILITY($J,"QAN IR/PAT",QANIEN)) Q:QANIEN'>0 D
19 . F QANPT=0:0 S QANPT=$O(^UTILITY($J,"QAN IR/PAT",QANIEN,QANPT)) Q:QANPT'>0 D TAB
20 D:'QANMSSG WAIT^DICD D ^QANQTTL ;Output of results.
21 D ^QANQSDT ;Generate a report based on the quarters data.
22EXIT ;Kill and quit
23 D KILL^XUSCLEAN K ^UTILITY($J,"QAN IR/PAT")
24 Q
25CHECK ;Check for existing quarterly data.
26 Q:'$D(^QA(742.6,"QDATE",QUBEG(QU))) ;no data
27 N Y S Y=QUBEG(QU) X ^DD("DD")
28 W !?5,"Quarterly Summary Data exists for the quarter beginning: ",Y
29 W !?5,"Do you wish to delete this quarters data?",*7 K DIR S DIR(0)="Y"
30 S DIR("?",1)="Enter ""Y"" to delete existing data AND calculate new data,",DIR("?")="Enter ""N"" to exit without updating data." D ^DIR K DIR
31 I 'Y S QANXIT=1 Q
32 S QANMSSG=1 D WAIT^DICD
33 L +^QA(742.6):5 ;Lock our global.
34 I '$T S QANXIT=1 W !!,*7,"Another person is editing this file, try again later.",!!,*7 L -^QA(742.6) Q
35 K DIK S DIK="^QA(742.6," F DA=0:0 S DA=$O(^QA(742.6,"QDATE",QUBEG(QU),DA)) Q:DA'>0 D ^DIK
36 L -^QA(742.6) ;Unlock after update.
37 Q
38PATFND ;Find the proper patient's ien for the associated incident.
39 ;This subroutine is not referenced if $D(^QA(742.4,"ACS",2,QANIEN))
40 ;this indicates a deleted incident record. Quit if the Bene Rpt flag
41 ;is not set to '1'. Do not set utility if the patient record status
42 ;is 'deleted'. PTCH 21 8/12/93
43 S QAN7424=$G(^QA(742.4,QANIEN,0)) Q:QAN7424']""!(+$P(QAN7424,U,17)'>0)
44 F QANPT=0:0 S QANPT=$O(^QA(742,"BCS",QANIEN,QANPT)) Q:QANPT'>0 D
45 . S:'$D(^QA(742,"BPRS",-1,QANPT)) ^UTILITY($J,"QAN IR/PAT",QANIEN,QANPT)=""
46 Q
47QUART ;Choose the quarter and the year.
48 W !!,"Enter Quarter Period and FY you wish to end with",!
49ENTERQ ;Enter the Quarter in question.
50 R !,"Enter Quarter and Year: ",QUART:DTIME S:'$T QUART="^" I (QUART="^")!(QUART="") S QAQQUIT=1 Q
51 I (QUART'?1N1P2N)&(QUART'?1N1P4N) W:$E(QUART)'="?" " ??",*7 W !!,"Enter Quarter Period in this format: 2nd quarter 1988 would be 2-88, 2/88, 2 88",! G ENTERQ
52 I ($E(QUART)>4)!($E(QUART)<1) W " ??",*7,!!,"Enter Quarter 1 to 4 only",! G ENTERQ
53 S QU=$E(QUART),YR=$E(QUART,3,6) K %DT S X=YR D ^%DT S YR=$E(Y,1,3)
54 S QUBEG(1)=YR-1_1001,QUBEG(2)=YR_"0101",QUBEG(3)=YR_"0401",QUBEG(4)=YR_"0701",QUEND(1)=YR-1_1231,QUEND(2)=YR_"0331",QUEND(3)=YR_"0630",QUEND(4)=YR_"0930",QUQUA(1)="FIRST",QUQUA(2)="SECOND",QUQUA(3)="THIRD",QUQUA(4)="FOURTH"
55 S QAQNBEG=QUBEG(QU),QAQNEND=QUEND(QU),QAQ2HED=QUQUA(QU)_" QUARTER FY "_(1700+YR)
56 Q
57TAB ;Setting up the variables for tabulation.
58 S QAN742=$G(^QA(742,QANPT,0)) Q:QAN742']""
59 S QAN7424=$G(^QA(742.4,QANIEN,0)) Q:QAN7424']""
60 S QANMED=$P($P(QAN7424,U),"."),QANINCD=$P(QAN7424,U,2)
61 S QANINVST=$S(+$P(QAN7424,U,11)=2:1,1:0),QANDTH=+$P(QAN7424,U,14)
62 S QANALPV=+$P(QAN7424,U,16),QANSVLV=+$P(QAN742,U,10)
63 D PATTYPE I $D(^QA(742.1,"BUPPER","DEATH",QANINCD)),QANDTH D DTH
64 D INVNON
65 Q
66DTH ;For Death
67 S QANDEATH=+$S($D(^QA(742.14,QANDTH,0)):$P(^(0),U,2),1:"") Q:'QANDEATH
68 I $D(QANARRY("QAN D",QANINCD,QANPTTY,QANDTH,QANINVST)) S QANARRY("QAN D",QANINCD,QANPTTY,QANDTH,QANINVST)=QANARRY("QAN D",QANINCD,QANPTTY,QANDTH,QANINVST)+1
69 E S QANARRY("QAN D",QANINCD,QANPTTY,QANDTH,QANINVST)=1
70 Q
71INVNON ;Invest/Non Invest
72 I $D(QANARRY(QANINCD,QANALPV,QANPTTY,QANINVST)) S QANARRY(QANINCD,QANALPV,QANPTTY,QANINVST)=QANARRY(QANINCD,QANALPV,QANPTTY,QANINVST)+1
73 E S QANARRY(QANINCD,QANALPV,QANPTTY,QANINVST)=1
74 I $D(QANARRY(QANINCD,QANALPV,QANPTTY,QANINVST,QANSVLV)) S QANARRY(QANINCD,QANALPV,QANPTTY,QANINVST,QANSVLV)=QANARRY(QANINCD,QANALPV,QANPTTY,QANINVST,QANSVLV)+1
75 E S QANARRY(QANINCD,QANALPV,QANPTTY,QANINVST,QANSVLV)=1
76 Q
77PATTYPE ;Finds the appropriate patient type.
78 S QANWD=$P(QAN742,U,6),QANPTTY=$S(+$P(QAN742,U,5)=1:"I",1:"O")
79 Q:QANWD']""
80 I $D(^SC(QANWD,42)) D
81 . S QANWD(1)=+$G(^SC(QANWD,42)) Q:QANWD(1)'>0
82 . S QANWD(2)=$P(^DIC(42,QANWD(1),0),U,3)
83 . S QANPTTY=$S(QANWD(2)="NH":"N",QANWD(2)="D":"D",1:"I")
84 Q
Note: See TracBrowser for help on using the repository browser.