source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRRMM.m@ 1258

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

initial load of WorldVistAEHR
File size: 5.4 KB
RevLine 
[613]1LRRMM ;CIOFO-DALLAS/JMC/SED -Lab Reports via Network Mail
2 ;;5.2;LAB SERVICE;**164**;Apr 09, 1993
3LAB ;Requires Lab 5.0 and Mailman 7.0 (Spooling to XMBS GlobaL)
4 ;Enter with LRRLROC=Interim Report Location (File 44 Abbreviation)
5 ; LRRVDT=Date to produce reports for (i.e. "T-1" would
6 ; produce reports for work verified yesterday)
7 ; LRRDEV=Name of the spool Device.
8 ; Default is "SPOOL80" if not defined.
9 ; LRRSITE=Name Of Referring Lab (Should be domain file
10 ; entry i.e "MILWAUKEE.VA.GOV")
11 ; LRRNORP=1 If "NEGATIVE" Mail Messages are -NOT- Required.
12 ;
13 S U="^" S:'$D(DTIME) DTIME=600
14 S:'$D(LRRNORP) LRRNORP=0 S X=$S($D(LRRVDT):LRRVDT,1:"T-1"),%DT="" D ^%DT Q:Y<1 S LRRVDT=Y D DD^LRX S LRRDATE=Y D ^LRPARAM
15 I '$D(^LRO(69,LRRVDT,1,"AN",LRRLROC))&(LRRNORP) Q
16 S:$G(LRRDEV)="" LRRDEV="SPOOL80"
17 D NOW^%DTC
18 S LRRNAME="LAB REPORTS "_$P(LRRSITE,".",1)_" "_%,IO("DOC")=LRRNAME,IOP=LRRDEV_";"_IO("DOC") D ^%ZIS
19 S (LRLAB,LREND,LRSTOP,LRFOOT)=0,(LRH,LRONESPC,LRONETST)="",LRCW=8,LRHF=1
20 U IO I '$D(^LRO(69,LRRVDT,1,"AN",LRRLROC)) W !,"No reports to transmit today." G MAIL
21 S LRDFN=0 F S LRDFN=$O(^LRO(69,LRRVDT,1,"AN",LRRLROC,LRDFN)) Q:LRDFN<1 D
22 .S LROC=LRRLROC D:LRFOOT FOOT^LRRP1 S LRFOOT=0,LRHF=1,LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX D
23 ..S LRIDT=0 F S LRIDT=$O(^LRO(69,LRRVDT,1,"AN",LRRLROC,LRDFN,LRIDT)) Q:LRIDT<1 D:$D(^LR(LRDFN,"CH",LRIDT)) CH^LRRP2 D:$D(^LR(LRDFN,"MI",LRIDT)) MI^LRRP2
24MAIL D:LRFOOT FOOT^LRRP1 W ! D ^%ZISC,KILL^XM
25 S XMDF=1,XMDUZ=DUZ,X="G.LAB REPORT" D WHO^XMA21
26 S X="G.LAB REPORT@"_LRRSITE D INST^XMA21
27 S XMSUB=^DD("SITE")_" LAB REPORTS FOR "_$P(LRRSITE,".",1)_" ON "_LRRDATE
28 D TSK^LRRMM
29 Q
30 ;
31ONELOC ;Entry point to create lab reports for one location.
32 D LAB,KILL Q
33 ;
34MANYLOC ;Entry point to create lab reports for several sites.
35 ;Enter with LRRLST=List of File #44 Locations (abbreviations)
36 ;Separated by ";" (i.e. LRRLST="XXX;YYY")
37 ;LRRDLST=List of corresponding domain names to send reports
38 ; to (i.e. LRRDLST="AAA.VA.GOV;BBB.VA.GOV")
39 F LRRZZ=1:1 S LRRLROC=$P(LRRLST,";",LRRZZ) Q:LRRLROC="" S LRRSITE=$P(LRRDLST,";",LRRZZ) D LAB
40 D KILL Q
41 ;
42ALLOC ;Entry point to send lab reports to all locations defined in
43 ;file #64.6 (interim reports) that have a domain name entered.
44 ;This requires a field "domain name" being added to #64.6 at
45 ;subscript ^LAB(64.6,D0,0), this is a pointer to the domain file.
46 S LRRZZ=0
47 F S LRRZZ=$O(^LAB(64.6,LRRZZ)) Q:'LRRZZ D
48 .S LRRZZ(0)=+$P($G(^LAB(64.6,LRRZZ,0)),U,7)
49 .I LRRZZ(0) S LRRLROC=$P($G(^SC(+$P(^LAB(64.6,LRRZZ,0),"^"),0)),"^",2),LRRSITE=$P($G(^DIC(4.2,LRRZZ(0),0)),"^") I LRRLROC]"",LRRSITE]"" D LAB
50 D KILL Q
51 ;
52KILL ;Cleanup before leaving.
53 S:$D(ZTQUEUED) ZTREQ="@"
54 K %,%DT,DFN,LRCW,LRDFN,LRDPF,LREND,LRFOOT,LRH,LRHF,LRIDT,LRLAB,LROC
55 K LRONESPC,LRONETST,LRSTOP,IOP,X,XMDF,Y,ZZ,LRRDATE,LRRDLST
56 K LRRLROC,LRRLST,LRRNAME,LRRNORP,LRRSITE,LRRVDT,LRRZZ,LRRDEV
57 D V^LRU,^LRKILL,KILL^XM
58 Q
59TSK ;Entry point from taskman to load a spool file into message.
60 ;Enter with XMSUB=header,XMY(SENDEE NAMES)=""
61 ;LRRNAME=name of spool document file to load into message.
62 K DIC S:'$D(DTIME) DTIME=300
63 S U="^",X=LRRNAME,DIC=3.51,DIC(0)="MZ"
64 D ^DIC Q:Y<1 S DA=+Y,ZISPL0=Y(0),ZISDA=DA K DIC
65DQMAIL W:'$D(ZTQUEUED) !,"Moving it..."
66 S XS=$P(ZISPL0,"^",10),XMY(DUZ)="",XMTEXT="^XMBS(3.519,"_XS_",2,"
67 D:XS>0 ^XMD D DSDOC^ZISPL(ZISDA),DSD^ZISPL(XS) W:'$D(ZTQUEUED) !," Now a normal mail message.."
68 I $G(XMZ) S XMDUZ=DUZ D NNEW^XMA ;Make message new for recipient.
69 D KILL1 Q
70 ;
71PRINT ;Entry point from menu option to extract text of message and print it.
72 D HOME^%ZIS K DIC
73ASK ;Select the mailman basket.
74 S DIC="^XMB(3.7,DUZ,2,",DIC(0)="AEMNQ",DIC("A")="Select Mail Basket: "
75 S DIC("B")="IN"
76 W ! D ^DIC G:Y<1 KILL1 S LRRMK=+Y,LRRMKN=$P(Y,"^",2)
77 K ^TMP($J) S (LRRMC,LRRMZ1)=0
78 F S LRRMZ1=$O(^XMB(3.7,DUZ,2,LRRMK,1,LRRMZ1)) Q:LRRMZ1<1 D
79 .S J=+^(LRRMZ1,0)
80 .Q:$P($G(^XMB(3.9,J,0)),U,1)'["LAB REPORT"
81 .S LRRMC=LRRMC+1,^TMP($J,"B",LRRMC)=J
82 W " ",$S(LRRMC=0:"No Lab",1:LRRMC)," Message",$S(LRRMC'=1:"s",1:"")," in basket." G:LRRMC=0 ASK
83LIST ;Select the message.
84 W @IOF,!,"Select from the following:" S (LRRMZ,LRROUT,I)=0
85 F S I=$O(^TMP($J,"B",I)) Q:'I S LRRMZ=^TMP($J,"B",I) D Q:LRROUT
86 .I $Y>(IOSL-5) K DIR S DIR(0)="E" D ^DIR K DIR S LRROUT=Y-1 W @IOF Q:LRROUT
87 .S LRRMR=$G(^XMB(3.9,LRRMZ,0)) Q:LRRMR="" S LRRMSUB=$P(LRRMR,U,1)
88 .I LRRMSUB["~U~" F S LRRMSUB=$P(LRRMSUB,"~U~",1)_"^"_$P(LRRMSUB,"~U~",2,99) Q:LRRMSUB'["~U~"
89 .W !,I," Subj: ",LRRMSUB," "
90 .S Y=$P(LRRMR,U,3),X1=+$P($G(^XMB(3.9,LRRMZ,2,0)),"^",4)
91 .I Y'?7N.E W Y
92 .E W $E(Y,4,5),"/",$E(Y,6,7),"/",$E(Y,2,3)," " S Y=$P(Y,".",2)_"0000" W "@ ",$E(Y,1,2),":",$E(Y,3,4)
93 .W " ",X1," Line",$S(X1>1:"s",1:"")
94 Q:LRROUT
95 K DIR S DIR(0)="NO^1:"_LRRMC_":0"
96 S DIR("A")="Select Message to Extract",DIR("B")=1
97 S DIR("?")="Enter the number of the message you want printed"
98 D ^DIR K DIR G:$D(DIRUT) ASK S LRRMZ=$G(^TMP($J,"B",Y))
99 S %IS="Q" D ^%ZIS I POP D HOME^%ZIS,KILL1 Q
100 I $D(IO("Q")) S ZTDESC="Extract Text of Mail Message",ZTSAVE("LRRMZ")="",ZTRTN="WRITE^LRRMM" D ^%ZTLOAD W !,"REQUEST ",$S($D(ZTSK):"",1:"NOT "),"QUEUED" K IO("Q"),ZTSK D ^%ZISC G ASK
101 D WRITE,KILL1 G ASK
102 ;
103WRITE ;Print the text of the message.
104 U IO S LRRCN=.9999
105 F S LRRCN=$O(^XMB(3.9,LRRMZ,2,LRRCN)) Q:'LRRCN S X=^(LRRCN,0) W:X="|TOP|" @IOF W:X'="|TOP|" X,!
106 W @IOF D ^%ZISC,KILL1 S:$D(ZTQUEUED) ZTREQ="@" Q
107 ;
108KILL1 K ^TMP($J),LRRCN,LRRMC,LRRMK,LRRMKN,LRRMR,LRRMZ,LRRMZ1
109 K LRRMSUB,LRROUT,%,%IS,DA,DIC,DIR,DIROUT,DIRUT,DUOUT,I,J
110 K POP,X,X1,XMZ,XS,Y,ZISDA,ZISPL0
111 Q
Note: See TracBrowser for help on using the repository browser.