source: FOIAVistA/trunk/r/INCIDENT_REPORTING-QAN/QANBRIF.m@ 1420

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

initial load of FOIAVistA 6/30/08 version
File size: 4.6 KB
Line 
1QANBRIF ;HISC/GJC-Auto E-Mail for locally quick cases ;8/6/93 10:01
2 ;;2.0;Incident Reporting;**1,18,20**;08/07/1992
3 ;
4 S QANZERO=$S($D(^QA(740,1,0))#2:^(0),1:0) I +QANZERO'>0 S QANERROR=1 D ERROR G EXIT
5 S QANSITE=$S($D(^DIC(4,+QANZERO,0))#2:$P(^(0),"^"),1:"") I QANSITE="" S QANERROR=2 D ERROR G EXIT
6 S QANSTNO=$S($D(^DIC(4,+QANZERO,99))#2:$P(^(99),"^"),1:"") I QANSTNO="" S QANERROR=3 D ERROR G EXIT
7 S QANSERV=$P(QANZERO,"^",4) I QANSERV="" S QANERROR=4 D ERROR G EXIT
8 S QANDOM=$P(QANZERO,"^",5) I QANDOM="" S QANERROR=5 D ERROR G EXIT
9 S QA=+$O(^DIC(4.2,"B",QANDOM,0)) I $S('$D(^DIC(4.2,QA,0))#2:1,$P(^(0),"^")'=QANDOM:1,1:0) S QANERROR=6 D ERROR G EXIT
10 S QANQAN=$S($D(^QA(740,1,"QAN")):^("QAN"),1:"") I +QANQAN'>0 S QANERROR=7 D ERROR G EXIT
11 S QANMLGP=+$P(QANQAN,U),QANMLGP(0)=$S($D(^XMB(3.8,QANMLGP,0))#2:$P(^(0),U),1:"") I QANMLGP(0)']"" S QANERROR=7 D ERROR G EXIT
12 D INC D:$D(^UTILITY($J,"QAN MAIL")) BULL
13EXIT ;Kill and quit
14 K ^UTILITY($J),C,DA,DIE,DIWF,DIWL,DIWR,DR,QA,QAN0,QAN1,QAN742
15 K QAN7424,QANCASE,QANDATE,QANDESC,QANDOM,QANERROR,QANINCD,QANINCR
16 K QANMLGP,QANNCDNT,QANLOOP,QANOK,QANPAT,QANPROV,QANQAN,QANQUIT,QANSERV
17 K QANSITE,QANSLEV,QANSRVCE,QANSTNO,QANTYDTH,QANZERO,X,XMDUZ,XMSUB
18 K QANDOB,XMTEXT,XMY,Y
19 Q
20BULL ;Mail message
21 D KILL^XM
22 S XMY(QANSERV_"@"_QANDOM)="",XMDUZ=.5
23 S XMSUB="QAN Incident Event: "_^DD("SITE")_" ("_^DD("SITE",1)_")"
24 S XMTEXT="^UTILITY($J,""QAN MAIL""," D ^XMD,KILL^XM
25 Q
26ERROR ;Error messages
27 W *7,!!,"*** ",$P($T(ERR+QANERROR),";;",2)," ***",!!,*7
28 Q
29INC ;Choose the incident. Check 'ACS' x-ref for brief.
30 S QANINCR=0
31 F QAN0=0:0 S QAN0=$O(^QA(742.4,"ACS",3,QAN0)) Q:QAN0'>0 S (QANDESC,QANQUIT)=0 D INC1
32 Q
33INC1 ;If brief 'ACS' x-ref, and not transmitted to region, 18th piece.
34 S QAN7424=$G(^QA(742.4,QAN0,0)) Q:QAN7424']""
35 Q:+$P(QAN7424,U,18)'=0 ;Has been xmitted.
36 S QANDATE=$P(QAN7424,U,3),QANCASE=$P(QAN7424,U),QANNCDNT=$P(QAN7424,U,2)
37 S QANINCD=$S($D(^QA(742.1,QANNCDNT,0)):$P(^(0),U),1:"") Q:QANINCD']""
38 S QANINCD=$TR(QANINCD,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
39 S QANTYDTH=$S(QANINCD="DEATH":$P(QAN7424,U,14),1:""),QANPROV=$P(QAN7424,U,16)
40 I $D(^QA(742.4,QAN0,1,0)) D DESC^QANFULL
41 ;/*** Grab patient data ***/
42 F QAN1=0:0 S QAN1=$O(^QA(742,"BCS",QAN0,QAN1)) Q:QAN1'>0 S QAN742=$G(^QA(742,QAN1,0)) S:QAN742]"" QANOK=0 D:QAN742]"" PAT
43 I QANQUIT K DA,DIE,DR S DIE="^QA(742.4,",DA=QAN0,DR=".17///^S X=3" D ^DIE K DA,DIE,DR
44 I QANQUIT K DA,DIE,DR S DIE="^QA(742.4,",DA=QAN0,DR=".21///^S X=1" D ^DIE K DA,DIE,DR
45 Q
46INCK ;Check status of incident
47 I QANINCD="HOMICIDE" S QANOK=1
48 I QANINCD="DEATH" D
49 . S QANTYDTH=+$G(QANTYDTH)
50 . I '$D(^QA(742.14,"BUPPER","OTHER",QANTYDTH)),('$D(^QA(742.14,"BUPPER","WITHIN 24 HOURS OF ADMISSION (EX. DOA'S AND TERMINALS)",QANTYDTH))) S QANOK=1
51 I QANINCD="SUICIDE" S QANOK=1
52 I QANINCD="SEXUAL ASSAULT" S QANOK=1
53 I QANINCD="SUICIDE ATTEMPT" S QANOK=1
54 I QANINCD="INFORMED CONSENT-FAIL. TO OBTAIN" S QANOK=1
55 I QANINCD="PATIENT ABUSE" S QANOK=1
56 I QANINCD="INJURY NOT OTHERWISE LISTED",(QANSLEV'<2) S QANOK=1
57 I QANINCD="ASSAULT-PATIENT TO PATIENT",(QANSLEV'<2) S QANOK=1
58 I QANINCD="FIRE-PATIENT INVOLVED IN",(QANSLEV'<2) S QANOK=1
59 I QANINCD="ASSAULT-PATIENT/STAFF",(QANSLEV'<2) S QANOK=1
60 I QANINCD="FALL",(QANSLEV'<2) S QANOK=1
61 I QANINCD="MEDICATION ERROR",(QANSLEV'<2) S QANOK=1
62 I QANINCD="TRANSFUSION ERROR",(QANSLEV'<2) S QANOK=1
63 I QANINCD="MISSING PATIENT",(QANSLEV'<2) S QANOK=1
64 Q
65PAT ;Patient data
66 S (QANSRVCE,Y)=$P(QAN742,U,8),C=$P(^DD(742,.08,0),U,2) D:Y]"" Y^DIQ S QANSRVCE=Y
67 S QANSLEV=+$P(QAN742,U,10) D INCK Q:'QANOK
68 S QANQUIT=1,QANINCR=QANINCR+1
69 S QANPAT=$P(QAN742,U),^UTILITY($J,"QAN PAT",QAN1)=$P(^DPT(QANPAT,0),U)
70 S ^UTILITY($J,"QAN SSN",QAN1)=$P(^DPT(QANPAT,0),U,9)
71 S QANDOB=$P(^DPT(QANPAT,0),U,3)
72 S ^UTILITY($J,"QAN MAIL",QANINCR)="BRIEF^"_QANCASE_"^INCD^"_QANINCD_"^"_QANDATE_"^^^^"_QANMLGP(0)_"^^^"_$G(QANPROV)_"^"
73 S QANINCR=QANINCR+1
74 S ^UTILITY($J,"QAN MAIL",QANINCR)="BRIEF^"_QANCASE_"^PAT^"_$G(^UTILITY($J,"QAN PAT",QAN1))_"^"_$G(^UTILITY($J,"QAN SSN",QAN1))_"^"_QANSLEV_"^"_QANTYDTH_"^"_QANSRVCE_"^^"_QANDOB_"^"
75 I QANDESC,($D(^UTILITY($J,"W",DIWL))) D
76 . F QA=0:0 S QA=$O(^UTILITY($J,"W",DIWL,QA)) Q:QA'>0 D
77 .. S QANINCR=QANINCR+1
78 .. S ^UTILITY($J,"QAN MAIL",QANINCR)="BRIEF^"_QANCASE_"^DESC^"_$G(^UTILITY($J,"W",DIWL,QA,0))_"^"
79 .. Q
80 . Q
81 Q
82ERR ;;ERROR MESSAGES: REASONS EWS BULLETIN COULD NOT BE SENT
83 ;;SITE NOT FOUND IN QA SITE PARAMETERS FILE
84 ;;SITE NOT FOUND IN INSTITUTION FILE
85 ;;SITE NUMBER NOT FOUND IN INSTITUTION FILE
86 ;;NQADB MAIL GROUP/SERVER NOT FOUND IN QA SITE PARAMETERS FILE
87 ;;NQADB DOMAIN NOT FOUND IN QA SITE PARAMETERS FILE
88 ;;NQADB DOMAIN NOT FOUND IN DOMAIN FILE
89 ;;QA INCIDENT MAILGROUP NOT FOUND IN QA SITE PARAMETERS FILE
Note: See TracBrowser for help on using the repository browser.