source: WorldVistAEHR/trunk/r/PATIENT_REPRESENTATIVE-QAC/QACMAIL1.m@ 1006

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

initial load of WorldVistAEHR

File size: 7.7 KB
Line 
1QACMAIL1 ;ERC/WASHCIOFO-Send data to reposititory ;11/29/99
2 ;;2.0;Patient Representative;**4,14,15,17**;07/25/1995
3 ;continuation routine - contains looping code, assigns variables
4 ;and stuffs values into temporary global ^TMP("QAC MAIL",$J,linecount)
5 ;
6ENV ;environment check - to ensure that the Mailman patch creating
7 ;domain has beem installed.
8 N QACQ,QACE,ZPDQUIT
9 S QACQ="Q-PSS.MED.VA.GOV"
10 Q:$$FIND1^DIC(4.2,,"QX",QACQ,"B",,"QACE")
11 W !!?5,$C(7),"**** Installation of this patch requires that domain "
12 W !?10,QACQ," be defined."
13 S XPDQUIT=1
14 W !!!?5,"Refer to patch XM*999*133 for domain definition information."
15 W !?15,"<Patch QAC*2.0*4 installation aborted!>",!!
16 Q
17LOOP ;
18 ;loop through file 745.1 looking for entries edited
19 ;since the previous rollup that have at least one issue code.
20 N QACD,QACDD,QACJ,QACLAST,QACOUNT
21 S QACJ=0
22 S QACLAST=$P($G(^QA(740,1,"QAC")),U,4)
23 ;(DBIA #3061 for lookup of value of QAC LAST RECORD in file #740)
24 S QACOUNT=0
25 F S QACJ=$O(^QA(745.1,"F",3,QACJ)) Q:QACJ'>0!($G(QACOUNT)>700) D WORK
26 I $G(QACLAST)'>0 D
27 . ;if QACLAST'>0, need to run rollup for the first time from 10/01/99
28 . S QACD=$O(^QA(745.1,"D",2991000)) Q:QACD'>0 D
29 . . S QACJ=$O(^QA(745.1,"D",QACD,QACJ)) Q:QACJ'>0 S QACJ=QACJ-1 D
30 . . . F S QACJ=$O(^QA(745.1,QACJ)) Q:QACJ'>0!($G(QACOUNT)>700) D WORK
31 S DIE="^QA(740,",DA=1,DR="753////^S X=QACLAST"
32 D ^DIE K DA,DIE,DR
33 Q
34WORK ;
35 D NODE0
36 S QACLAST=QACJ
37 S QACOUNT=QACOUNT+1
38 S DIE="^QA(745.1,",DA=QACJ,DR="41///@" D ^DIE K DA,DIE,DR
39 Q
40DATA ; Set data into local variables and then into ^TMP global for
41 ; inclusion in mail message.
42 N QACNODE2,QACNODE7
43 N QACK,QACL,QACM,QACN
44 N QACCOM,QACDAT,QACDATE,QACDAYS,QACDISC,QACDIV,QACDOB,QACELIG,QACISSC
45 N QACLSAT,QACMADE,QACNO,QACPGV,QACPSRV,QACRDAT,QACRDATE,QACROC
46 N QACSEAT,QACSEX,QACSSN,QACSTAT,QACTST
47 ;if record was previously rejected and is now closed set Roll-up status
48 ;to "0" (call ROLL(0)) - if still open but has IC call ROLL(2)
49 ;if record previously sent but "open", but is now closed, call ROLL(0)
50 N QACNOT
51 S QACROC=$P($G(QACNODE0),U)
52 I $G(QACNODE0)]"" D
53 . I $P($G(QACNODE0),U,3)]"" D
54 . . S QACSSN=$P(VADM(2),U) ;SSN
55 . . S QACDOB=$P(VADM(3),U) ;DOB
56 . . I $G(QACDOB) D ;Austin wanted dates in MMDDYYYY
57 . . . S QACDOB=$P($$FMTHL7^XLFDT(QACDOB),"-")
58 . . . S QACDOB=$E(QACDOB,5,8)_$E(QACDOB,1,4)
59 . . S QACSEX=$P(VADM(5),U)
60 . S QACDATE=$P(QACNODE0,U,2) ;date of contact
61 . I $G(QACDATE) D
62 . . S QACDATE=$P($$FMTHL7^XLFDT(QACDATE),"-")
63 . . S QACDATE=$E(QACDATE,5,8)_$E(QACDATE,1,4)
64 . S QACPSRV=$P($G(QACNODE0),U,14) ;period of service
65 . S QACPGV=$P($G(QACNODE0),U,15) ;Persian Gulf vet?
66 . S QACDIV=""
67 . I $P($G(QACNODE0),U,16)]"" D DIV16
68 . ;S QACDIV=$E(QACDIV,1,30)
69 . I $G(QACDIV)["Unknown" S QACDIV=""
70 . S QACELIG=$S($P($G(QACNODE0),U,4)]"":$O(^DIC(8,"B",$P($G(QACNODE0),U,4),0)),1:"UNK") ;eligibility
71 . S QACMADE=$P(QACNODE0,U,10)
72NODE2 ; set variables for node 2
73 S QACNODE2=$G(^QA(745.1,QACJ,2))
74 I QACNODE2]"" S QACTST=$P($G(QACNODE2),U,2) ;treatment status
75 S QACINTAP=$P($G(QACNODE2),U,7) ;Internal Appeal
76NODE3 ;issue code info
77 S QACK=0
78 F S QACK=$O(^QA(745.1,QACJ,3,QACK)) Q:QACK'>0 D
79 . S QACISSC(QACK)=$P(^QA(745.2,^QA(745.1,QACJ,3,QACK,0),0),U)
80 . I $P($G(^QA(745.1,QACJ,3,QACK,3,0)),U,3)'>0 S QACDISC(QACK,1)=QACISSC(QACK)_"^"
81 . S QACL=0
82 . F S QACL=$O(^QA(745.1,QACJ,3,QACK,3,QACL)) Q:QACL'>0 D
83 . . ;get code for discipline
84 . . N QACTEMP,QACTMP
85 . . S QACTMP=$P($G(^QA(745.1,QACJ,3,QACK,3,QACL,0)),U,2)
86 . . S QACTEMP=$S($G(QACTMP)]"":$P($G(^QA(745.5,QACTMP,0)),U),1:"")
87 . . S QACDISC(QACK,QACL)=QACISSC(QACK)_"^"_$G(QACTEMP)
88NODE7 ;set variables for node 7
89 S QACNODE7=$G(^QA(745.1,QACJ,7)) I $G(QACNODE7)]"" D
90 . S QACSTAT=$P($G(QACNODE7),U,2) ;status
91 . S QACRDATE=$P(QACNODE7,U) ;resolution date
92 . I $G(QACRDATE) D
93 . . S QACRDATE=$P($$FMTHL7^XLFDT(QACRDATE),"-")
94 . . S QACRDATE=$E(QACRDATE,5,8)_$E(QACRDATE,1,4)
95 . S QACDAYS=$P($G(QACNODE7),U,4) ;days to resolution
96NODE8 ; set variables for employee multiple
97 N QACC
98 S QACC=0
99 K QACEM,QACEMP
100 F S QACC=$O(^QA(745.1,QACJ,8,QACC)) Q:QACC'>0 D
101 . S QACEM=^QA(745.1,QACJ,8,QACC,0) Q:QACEM'>0
102 . S QACEM=$P($G(^VA(200,QACEM,0)),U)
103 . I $G(QACEM)]"" S QACEMP(QACJ,QACC)=QACEM
104NODE12 ; set variables for source(s) of contact multiple
105 N QACD,QACSOR,QACSR
106 S QACD=0
107 F S QACD=$O(^QA(745.1,QACJ,12,QACD)) Q:QACD'>0 D
108 . S QACSR=^QA(745.1,QACJ,12,QACD,0) Q:QACSR']""
109 . I $G(QACSR)]"" S QACSOR(QACJ,QACD)=QACSR
110STUFF ; Stuff variables into ^TMP global for use in ^XMD
111 ; field delimiter = "^"
112 ; line delimiter = "&"
113 ; record delimiter = "$"
114 ; message delimiter = "#"
115 N QACJJ,QACKK,QACLL
116 S QACRCNT=QACRCNT+1
117 ;check message size - need to ensure message < 32000
118 I $G(QACTCNT)>29000 D NEWMSG^QACMAIL0
119 X QACINC
120 S ^TMP("QAC MAIL",$J,QACLCNT)=$G(QACROC)_"^ROC^"_$G(QACDATE)_"^"_$G(QACSSN)_"^"_$G(QACSEX)_"^"_$G(QACDOB)_"^"_$G(QACSTAT)_"^"_$G(QACRDATE)_"^"_$G(QACTST)_"^"_$G(QACPSRV)
121 S ^TMP("QAC MAIL",$J,QACLCNT)=^TMP("QAC MAIL",$J,QACLCNT)_"^"_$G(QACPGV)_"^"_$G(QACDIV)_"^"_$G(QACDAYS)_"^"_$G(QACELIG)_"^"_$G(QACMADE)_"^"_$G(QACVISN)_"^"_$G(QACINTAP)_"&"
122STFFISSC ;stuff issue code values into ^TMP
123 ;using "~" as an Issue Code delimiter
124 N QACCHCNT
125 S (QACJJ,QACKK)=0
126 I $O(QACISSC(0))'>0 Q
127 X QACINC S ^TMP("QAC MAIL",$J,QACLCNT)=$G(QACROC)_"^ISSC^"
128 F S QACJJ=$O(QACDISC(QACJJ)) Q:QACJJ'>0 D
129 . S QACKK=0
130 . F S QACKK=$O(QACDISC(QACJJ,QACKK)) Q:QACKK'>0 D
131 . . N QACLIN,QACLINE
132 . . S QACLINE=QACDISC(QACJJ,QACKK)
133 . . ; adding employee(s) to each issue code. In future employee (and
134 . . ; location) will be associated with Issue Code - code will change
135 . . ; here. For now, location will be represented by "" in last piece
136 . . ; There will be one IC, one Disc., one location and one employee
137 . . ; separated by "^", and each 4 field set separated by "~"
138 . . S (QACE,QACCHCNT)=0
139 . . I $O(QACEMP(0))'>0 S ^TMP("QAC MAIL",$J,QACLCNT)=^TMP("QAC MAIL",$J,QACLCNT)_QACLINE_"^^~"
140 . . F S QACE=$O(QACEMP(QACJ,QACE)) Q:QACE'>0 D
141 . . . S QACLIN=QACLINE_"^"_$G(QACEMP(QACJ,QACE))_"^~" ;space for loc
142 . . . I $L(QACLIN)+$L(^TMP("QAC MAIL",$J,QACLCNT))>200 D
143 . . . . X QACINC
144 . . . . S ^TMP("QAC MAIL",$J,QACLCNT)=""
145 . . . S ^TMP("QAC MAIL",$J,QACLCNT)=^TMP("QAC MAIL",$J,QACLCNT)_QACLIN
146 . . . S QACLIN=""
147 S ^TMP("QAC MAIL",$J,QACLCNT)=^TMP("QAC MAIL",$J,QACLCNT)_"&"
148STFFSOUR ;stuff values for source(s) of contact into ^TMP
149 X QACINC
150 S ^TMP("QAC MAIL",$J,QACLCNT)=$G(QACROC)_"^SOUR"
151 N QACF
152 S QACF=0
153 F S QACF=$O(QACSOR(QACJ,QACF)) Q:QACF'>0 D
154 . S ^TMP("QAC MAIL",$J,QACLCNT)=^TMP("QAC MAIL",$J,QACLCNT)_"^"_$G(QACSOR(QACJ,QACF))
155 S ^TMP("QAC MAIL",$J,QACLCNT)=^TMP("QAC MAIL",$J,QACLCNT)_"$"
156 Q
157NODE0 ;set values from zero node
158 N DFN,QACNAME,QACNODE0,QACNOFLG,VADM
159 S QACNODE0=^QA(745.1,QACJ,0)
160 I $P($G(QACNODE0),U,3)]"" D
161 . S DFN=$P(QACNODE0,U,3)
162 . D ^VADPT
163 S QACNAME=$S($G(VADM(1))]"":VADM(1),1:"No Patient Involved")
164 ;If no issue code count record and go to next entry.
165 I $P($G(^QA(745.1,QACJ,3,0)),U,3)<1 D
166 . S QACNOCNT=$G(QACNOCNT)+1,QACNOT=1
167 . ;D ROLL^QACMAIL0(1) ;sets Roll-Up Status to rejected
168 . Q
169 I $G(QACNOT)=1 S QACNOT=0 Q
170 D DATA
171 Q
172LOOP1 ;post-install to check previously rejected records (see if they now
173 ;have Issue Codes) and to get any records since last run of the
174 ;rollup. for QAC*2*17. will set these records to a Rollup Status
175 ;of 3, which means they will be transmitted with the next run.
176 N QACF,QACJ
177 F QACF=1,2 S QACJ=0 D
178 . F S QACJ=$O(^QA(745.1,"F",QACF,QACJ)) Q:QACJ'>0 D
179 . . I $P($G(^QA(745.1,QACJ,3,0)),U,3)'>0 D DIE("@") Q
180 . . D DIE(3)
181 S QACJ=$P(^QA(740,1,"QAC"),U,4)
182 I $G(QACJ)']"" Q
183 F S QACJ=$O(^QA(745.1,QACJ)) Q:QACJ'>0 D
184 . D DIE(3)
185 Q
186DIE(QACE) ;
187 S DIE="^QA(745.1,",DA=QACJ,DR="41///^S X=QACE"
188 D ^DIE
189 K DA,DIE,DR,QACE
190 Q
191DIV16 ;division field, #37
192 S QACNO=$P($G(QACNODE0),U,16)
193 ;D INST^QACUTL0(QACNO,.QACDIV)
194 S QACDIV=$P($G(^DIC(4,QACNO,99)),U)
195 Q
Note: See TracBrowser for help on using the repository browser.