source: WorldVistAEHR/trunk/r/PATIENT_REPRESENTATIVE-QAC/QACALRT1.m@ 1150

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

initial load of WorldVistAEHR

File size: 4.7 KB
Line 
1QACALRT1 ;HISC/DAD-PROCESS AN ALERT ;3/23/95 10:22
2 ;;2.0;Patient Representative;**3,7,6,9,12**;07/25/1995
3EN ;
4 N QACDATE
5 K QACDELET
6 S QACX=$P(XQADATA,U),QACD0=$P(XQADATA,U,2),QACDUZ=$P(XQADATA,U,3)
7 S QACXQAID=$P(XQAID,";")
8 ;
9 ; Display contact information when alert processed.
10 S QAC=QACD0,QACRES=0 D START1^QACRPT
11 ;
12 S QAC=$S($D(^QA(745.1,QACD0,0))[0:1,$P($G(^(7)),U,2)="C":2,1:0)
13 I QAC D G EXIT
14 . W !!?5,"*** The Patient Rep record associated with this alert"
15 . W ?63,"***",!?5,"*** has been ",$P("deleted^closed",U,QAC)
16 . W ". No response needed, killing alert.",?63,"***",$C(7)
17 . D KILLALRT
18 . Q
19 ;
20 I $O(^XTMP(QACXQAID,"TXT",0)) D
21 . W !!?5,"*** You have an unsent response to this alert. ***",$C(7)
22 . Q
23 ;
24 ; Alert action (Respond / Ignore / Delete / Print)
25 K DIR S QACACTN=""
26 F D Q:QACACTN]""
27 . S DIR(0)="SOM^R:Respond;I:Ignore;D:Delete;P:Print"
28 . S DIR("A")="Alert action"
29 . S DIR("?",1)=" Enter (R)espond to enter your response to this alert."
30 . S DIR("?",2)=" Enter (I)gnore to save this alert for a later response."
31 . S DIR("?",3)=" Enter (D)elete to delete this alert without a response."
32 . S DIR("?",4)=" Enter (P)rint to print the report of contact."
33 . S DIR("?")=" Enter one of the codes listed above."
34 . W ! D ^DIR S QACACTN=$S($D(DIRUT):U,1:Y)
35 . I QACACTN="P" D
36 .. S QAC=QACD0,QACRES=0
37 .. N QACD0,QACX,QACXQAID
38 .. D EN^QACRPT
39 .. S QACACTN="",DIR("B")="Ignore"
40 .. Q
41 . Q
42 I (QACACTN="I")!(QACACTN=U) D SAVEALRT
43 I QACACTN="D" S QACDELET=1 D RESPOND,KILLALRT
44 I QACACTN="R" D RESPOND
45 G EXIT
46 ;
47RESPOND ; Get user's response
48 I $O(^XTMP(QACXQAID,"TXT",0))'>0 K ^XTMP(QACXQAID)
49 K DIC,DIWEPSE,DTOUT,DWLW,DWPK
50 S ^XTMP(QACXQAID,0)=$$FMADD^XLFDT(DT,14)_U_DT
51 I $G(QACDELET)<1 D
52 . S DIC="^XTMP("""_QACXQAID_""",""TXT"","
53 . D EN^DIWE
54 I $G(QACDELET)=1 D DELMSG
55 I $O(^XTMP(QACXQAID,"TXT",0))'>0 K ^XTMP(QACXQAID) D SAVEALRT Q
56 I $D(DTOUT) D Q
57 . W $C(7),!
58 . W !?5,"*** You have timed out while entering a response. ***"
59 . W !?5,"*** The text can be recovered if you re-enter the alert. ***"
60 . W !?5,"*** If not, it will be automatically purged in two weeks. ***"
61 . D SAVEALRT
62 . Q
63 S QACX(0)=$P($G(^VA(200,QACX,0)),U) I QACX(0)="" S QACX(0)="UNKNOWN"
64 S QACHDR="*** "_$$FMTE^XLFDT($$NOW^XLFDT,"2PS")_" "_QACX(0)_" ***"
65 S ^XTMP(QACXQAID,"TXT",.1,0)=""
66 S ^XTMP(QACXQAID,"TXT",.2,0)=QACHDR
67 S ^XTMP(QACXQAID,"TXT",.3,0)=""
68 ; Save user's response
69 W !!,"Saving your response, please wait . . . "
70 K ^TMP("QACALRT1",$J)
71 S %X="^XTMP("""_QACXQAID_""",""TXT"","
72 S %Y="^TMP(""QACALRT1"",$J,"
73 D %XY^%RCR
74 S ZTRTN="TASK^QACALRT1",ZTDESC="Patient Rep resolution comments update"
75 S (ZTSAVE("QACD0"),ZTSAVE("^TMP(""QACALRT1"",$J,"),ZTIO)="",ZTDTH=$H
76 S (ZTSAVE("QACX"),ZTSAVE("QACDUZ"))=""
77 S ZTSAVE("QACDELET")=""
78 D ^%ZTLOAD
79 W "Done"
80KILLALRT ; Kill this alert
81 K ^XTMP(QACXQAID)
82 S XQAKILL=1
83 Q
84SAVEALRT ; Do not kill this alert
85 K XQAKILL
86 Q
87 ;
88TASK ; Tasked entry point
89 F L +^QA(745.1,QACD0):5 Q:$T H 5
90 I $D(^QA(745.1,QACD0,0))[0 L -^QA(745.1,QACD0) G EXIT
91 S (QACD1,QACD1(0))=0
92 F S QACD1=$O(^QA(745.1,QACD0,6,QACD1)) Q:QACD1'>0 S QACD1(0)=QACD1
93 S (QACTMP,QACOUNT)=0
94 F S QACTMP=$O(^TMP("QACALRT1",$J,QACTMP)) Q:QACTMP'>0 D
95 . S QACOUNT=QACOUNT+1
96 . S ^QA(745.1,QACD0,6,QACD1(0)+QACOUNT,0)=^TMP("QACALRT1",$J,QACTMP,0)
97 . Q
98 S QACOUNT=QACOUNT+1
99 S ^QA(745.1,QACD0,6,QACD1(0)+QACOUNT,0)=""
100 S QACOUNT=QACOUNT+1
101 S ^QA(745.1,QACD0,6,QACD1(0)+QACOUNT,0)="*** End of response ***"
102 S QACWPHDR=$G(^QA(745.1,QACD0,6,0))
103 S $P(QACWPHDR,U,3)=($P(QACWPHDR,U,3)+QACOUNT)
104 S $P(QACWPHDR,U,4)=($P(QACWPHDR,U,4)+QACOUNT)
105 S $P(QACWPHDR,U,5)=DT
106 S ^QA(745.1,QACD0,6,0)=QACWPHDR
107 L -^QA(745.1,QACD0)
108 S QACX(0)=$P($G(^VA(200,+QACX,0)),U) S:QACX(0)="" QACX(0)="UNKNOWN"
109 S QACCASE=$P($G(^QA(745.1,+QACD0,0)),U) S:QACCASE="" QACCASE="UNKNOWN"
110 S XQA(+QACDUZ)=""
111 S XQAMSG="Patient Rep response by "_QACX(0)_" to "_QACCASE_"."
112 I $G(QACDELET)=1 S XQAMSG="Patient Rep Alert "_QACCASE_" deleted by "_QACX(0)_"."
113 D SETUP^XQALERT
114 ;D SET^QACALRT0(+QACDUZ,QACD0)
115EXIT ;
116 S:$D(ZTQUEUED) ZTREQ="@"
117 K DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,QAC,QACACTN,QACCASE,QACD0,QACD1
118 K QACDUZ,QACEE,QACHDR,QACOUNT,QACRES,QACTMP,QACWPHDR,QACX,QACXQAID,X,Y
119 K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,^TMP("QACALRT1",$J),%X,%Y
120 Q
121DELMSG ;If user deletes an alert on a report of contact a message is sent
122 ;as if it were a response to the alert. It will be stored in the
123 ;Resolution Comments field.
124 S $P(^XTMP(QACXQAID,"TXT",0),U,5)=DT
125 F QACEE=3,4 S $P(^XTMP(QACXQAID,"TXT",0),U,QACEE)=$P(^XTMP(QACXQAID,"TXT",0),U,QACEE)+1
126 S Y=DT D DD^%DT S QACDATE=Y
127 S QACNAME=$P($P(^VA(200,DUZ,0),U),",",2)_" "_$P($P(^VA(200,DUZ,0),U),",")
128 S ^XTMP(QACXQAID,"TXT",1,0)="VA Alert on Report of Contact "_$P(QACXQAID,"-",2)_" deleted by "_QACNAME_" on "_QACDATE
129 Q
Note: See TracBrowser for help on using the repository browser.