source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRAPTIUP.m@ 792

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

initial load of FOIAVistA 6/30/08 version

File size: 4.7 KB
Line 
1LRAPTIUP ;DALOI/WTY - API Print AP Reports from TIU;09/05/2001
2 ;;5.2;LAB SERVICE;**259**;Sep 27, 1994
3 ; This API is used to extract Anatomic Pathology reports that have
4 ; been stored in TIU and print them.
5 ;
6 ;Reference to EXTRACT^TIULQ supported by IA #2693
7 ;
8MAIN(LRTIUDA,LRDEV) ; Control Branching
9 ;
10 ; LRTIUDA - IEN of document from TIU DOCUMENT (#8925) file
11 ; LRDEV - 1 indicates use device handling in this routine
12 ; 0 indicates use device handling of calling application
13 ;
14 K ^TMP("LRTIU",$J),^TMP("LRTIUTXT",$J)
15 N LRCNT,LRCNTT,LROR,LRFLG,LRTXT,LRHFLG,LRCNTF
16 S LRDEV=+$G(LRDEV)
17 S LRQUIT=0
18 I '$G(LRTIUDA) D Q
19 .W $C(7),!,"The IEN from the TIU DOCUMENT (#8925) file is undefined.",!
20 D EXTRACT
21 I LRQUIT D END Q
22 D DISSECT
23 I LRQUIT D END Q
24 D:LRDEV ASKDEV
25 I $G(POP)!LRQUIT D END Q
26 D REPORT
27 D END
28 Q
29EXTRACT ;Extract the report from TIU
30 D EXTRACT^TIULQ(LRTIUDA,"^TMP(""LRTIU"",$J)",,,,1,,1)
31 I '+$P($G(^TMP("LRTIU",$J,LRTIUDA,"TEXT",0)),"^",3) D Q
32 .W $C(7),!!,"Document not found.",!
33 .S LRQUIT=1
34 M ^TMP("LRTIUTXT",$J)=^TMP("LRTIU",$J,LRTIUDA,"TEXT")
35 Q
36DISSECT ;Dissect the report into header,body, and footer
37 S (LROR,LRCNT,LRCNTT,LRHFLG)=0,LRFLG="H"
38 F S LROR=$O(^TMP("LRTIUTXT",$J,LROR)) Q:LROR'>0!(LRQUIT) D
39 .S LRTXT=$G(^TMP("LRTIUTXT",$J,LROR,0))
40 .I 'LRHFLG,LRTXT'="$APHDR" D Q
41 ..W $C(7),!!,"Document is not an Anatomic Pathology report.",!
42 ..S LRQUIT=1
43 .I LRTXT="$APHDR" D Q
44 ..S LRHFLG=1
45 ..K ^TMP("LRTIUTXT",$J,LROR)
46 .I LRFLG="H" D Q:LRFLG="T"
47 ..I LRTXT="$TEXT" D Q
48 ...S ^TMP("LRTIUTXT",$J,"HDR")=LRCNT,LRCNT=0
49 ...K ^TMP("LRTIUTXT",$J,LROR)
50 ...S LRFLG="T",LRCNT=0
51 ..Q:LRFLG="T"
52 ..S LRCNT=LRCNT+1,LRCNTT=LRCNTT+1
53 ..S ^TMP("LRTIUTXT",$J,"HDR",LRCNT)=LRTXT
54 ..K ^TMP("LRTIUTXT",$J,LROR)
55 .I LRFLG="T" D Q:LRFLG="F"
56 ..I LRTXT="$FTR" D Q:LRFLG="F"
57 ...S ^TMP("LRTIUTXT",$J,"TEXT")=LRCNT,LRCNT=0
58 ...K ^TMP("LRTIUTXT",$J,LROR)
59 ...S LRFLG="F"
60 ..Q:LRFLG="F"
61 ..S LRCNT=LRCNT+1,LRCNTT=LRCNTT+1
62 ..S ^TMP("LRTIUTXT",$J,"TEXT",LRCNT)=LRTXT
63 ..K ^TMP("LRTIUTXT",$J,LROR)
64 .I LRFLG="F" D
65 ..S LRCNT=LRCNT+1,LRCNTT=LRCNTT+1
66 ..S ^TMP("LRTIUTXT",$J,"FTR",LRCNT)=LRTXT
67 ..K ^TMP("LRTIUTXT",$J,LROR)
68 S ^TMP("LRTIUTXT",$J,"FTR")=LRCNT
69 S ^TMP("LRTIUTXT",$J,0)=LRCNTT
70 Q
71ASKDEV ;
72 W !
73 S %ZIS="Q" D ^%ZIS
74 I POP W ! S LRQUIT=1 Q
75 I $D(IO("Q")) D
76 .S ZTDESC="Print Anat Path Reports"
77 .S ZTRTN="REPORT^LRAPTIUP"
78 .D ^%ZTLOAD W:$D(ZTSK) !,"Request Queued, #",ZTSK W !
79 .K ZTSK,IO("Q") D HOME^%ZIS
80 .S LRQUIT=1
81 Q
82REPORT ;
83 U IO W:IOST?1"C-".E @IOF
84 N LRPG,LRHDC,LRFTC,LRTXC,LRTOTPGS,LROR1,LROR2,LREND
85 S (LRQUIT,LRPG,LREND)=0
86 S LRHDC=+$G(^TMP("LRTIUTXT",$J,"HDR"))
87 S LRFTC=+$G(^TMP("LRTIUTXT",$J,"FTR"))
88 S LRTXC=+$G(^TMP("LRTIUTXT",$J,"TEXT"))
89 S LRTOTPGS=LRTXC\(IOSL-LRHDC-LRFTC-4)
90 S:LRTXC#(IOSL-LRHDC-LRFTC-4) LRTOTPGS=LRTOTPGS+1
91 D HEADER
92 Q:LRQUIT
93 ;Calculate LR and TIU checksums, if they don't match, set flag
94 ; to scramble signature on the report.
95 D CHKSUM
96 I LRCKSUM'=0,LRCKSUM'=TIUCKSUM S LRENCRYP=1
97 D BODY
98 Q:LRQUIT
99 S LREND=1
100 D FOOTER
101 Q
102HEADER ;Report Header
103 I LRPG>0,IOST?1"C-".E D Q:LRQUIT
104 .K DIR S DIR(0)="E"
105 .D ^DIR W !
106 .S:$D(DTOUT)!(X[U) LRQUIT=1
107 W:LRPG>0 @IOF S LRPG=LRPG+1
108 S LROR=0 F S LROR=$O(^TMP("LRTIUTXT",$J,"HDR",LROR)) Q:LROR'>0 D
109 .S LRTXT=$G(^TMP("LRTIUTXT",$J,"HDR",LROR))
110 .W LRTXT
111 .I LRTXT["MEDICAL RECORD"!(LRTXT["AUTOPSY PROTOCOL") D
112 ..Q:IOST["BROWSER"
113 ..W ?68,"Pg",$J(LRPG,3)," of ",LRTOTPGS
114 .W !
115 Q
116BODY ;Body of Report
117 S LROR1=0
118 F S LROR1=$O(^TMP("LRTIUTXT",$J,"TEXT",LROR1)) Q:LROR1'>0!(LRQUIT) D
119 .I $Y>(IOSL-LRFTC-5) D FOOTER,HEADER Q:LRQUIT
120 .S LRTXT=$G(^TMP("LRTIUTXT",$J,"TEXT",LROR1))
121 .I LRTXT["/es/",+$G(LRENCRYP) S LRTXT=$$ENCRYP^XUSRB1(LRTXT)
122 .W LRTXT,!
123 Q
124FOOTER ;Report Footer
125 S (LROR2,LRCNTF)=0
126 I IOSL'>66 F Q:$Y>(IOSL-LRFTC-5) W !
127 F S LROR2=$O(^TMP("LRTIUTXT",$J,"FTR",LROR2)) Q:LROR2'>0 D
128 .S LRCNTF=LRCNTF+1
129 .S LRTXT=$G(^TMP("LRTIUTXT",$J,"FTR",LROR2))
130 .I LRCNTF=2 D Q
131 ..I LRTXT'=""&(LRTXT'["(End") W LRTXT,! Q
132 ..I 'LREND W ?57,"(See next page)",! Q
133 ..W ?57,"(End of report)",!
134 .W LRTXT,!
135 Q
136CHKSUM ;Compare LR and TIU checksums
137 ;Get original checksum value from file 63
138 N LRTREC,LRROOT,LRFILE,LRIENS,LRFLD,LRREL
139 S (LRENCRYP,LRTREC)=0
140 I LRSS="AU" D
141 .S LRTREC=$O(^LR(LRDFN,101,"C",LRPTR,LRTREC))
142 .S LRIENS=LRDFN_","
143 .S LRFILE=63.101
144 I LRSS'="AU" D
145 .S LRTREC=$O(^LR(LRDFN,LRSS,LRI,.05,"C",LRPTR,LRTREC))
146 .S LRIENS=LRI_","_LRDFN_","
147 .S LRFILE=$S(LRSS="SP":63.19,LRSS="CY":63.47,LRSS="EM":63.49,1:"")
148 I LRFILE=""!(LRTREC=0) S LRCKSUM=0 Q
149 ;Retrieve LR checksum
150 S LRIENS=LRTREC_","_LRIENS
151 S LRCKSUM=$$GET1^DIQ(LRFILE,LRIENS,2)
152 I LRCKSUM="" S LRCKSUM=0
153 ;Calculate TIU checksum
154 S TIUVAL="^TIU(8925,"_LRPTR_",""TEXT"")"
155 S TIUCKSUM=$$CHKSUM^XUSESIG1(TIUVAL)
156 Q
157END ;
158 W:IOST?1"P-".E @IOF
159 I LRDEV D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
160 K ^TMP("LRTIU",$J),^TMP("LRTIUTXT",$J)
161 K %,DIR,DTOUT,DUOUT,DIRUT,X,Y
162 Q
Note: See TracBrowser for help on using the repository browser.