source: FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LRRMM.m@ 628

LRRMM ;CIOFO-DALLAS/JMC/SED -Lab Reports via Network Mail
 ;;5.2;LAB SERVICE;**164**;Apr 09, 1993
LAB ;Requires Lab 5.0 and Mailman 7.0 (Spooling to XMBS GlobaL)
 ;Enter with LRRLROC=Interim Report Location (File 44 Abbreviation)
 ;    LRRVDT=Date to produce reports for (i.e. "T-1" would 
 ;           produce reports for work verified yesterday)
 ;    LRRDEV=Name of the spool Device. 
 ;           Default is "SPOOL80"  if not defined.
 ;   LRRSITE=Name Of Referring Lab (Should be domain file
 ;           entry i.e "MILWAUKEE.VA.GOV")
 ;   LRRNORP=1 If "NEGATIVE" Mail Messages are -NOT- Required.
 ;
 S U="^" S:'$D(DTIME) DTIME=600
 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
 I '$D(^LRO(69,LRRVDT,1,"AN",LRRLROC))&(LRRNORP) Q
 S:$G(LRRDEV)="" LRRDEV="SPOOL80"
 D NOW^%DTC
 S LRRNAME="LAB REPORTS "_$P(LRRSITE,".",1)_" "_%,IO("DOC")=LRRNAME,IOP=LRRDEV_";"_IO("DOC") D ^%ZIS
 S (LRLAB,LREND,LRSTOP,LRFOOT)=0,(LRH,LRONESPC,LRONETST)="",LRCW=8,LRHF=1
 U IO I '$D(^LRO(69,LRRVDT,1,"AN",LRRLROC)) W !,"No reports to transmit today." G MAIL
 S LRDFN=0 F  S LRDFN=$O(^LRO(69,LRRVDT,1,"AN",LRRLROC,LRDFN)) Q:LRDFN<1  D
 .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
 ..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
MAIL D:LRFOOT FOOT^LRRP1 W ! D ^%ZISC,KILL^XM
 S XMDF=1,XMDUZ=DUZ,X="G.LAB REPORT" D WHO^XMA21
 S X="G.LAB REPORT@"_LRRSITE D INST^XMA21
 S XMSUB=^DD("SITE")_" LAB REPORTS FOR "_$P(LRRSITE,".",1)_" ON "_LRRDATE
 D TSK^LRRMM
 Q
 ;
ONELOC ;Entry point to create lab reports for one location.
 D LAB,KILL Q
 ;
MANYLOC ;Entry point to create lab reports for several sites.
 ;Enter with LRRLST=List of File #44 Locations (abbreviations) 
 ;Separated by ";" (i.e. LRRLST="XXX;YYY")
 ;LRRDLST=List of corresponding domain names to send reports
 ;         to (i.e. LRRDLST="AAA.VA.GOV;BBB.VA.GOV")
 F LRRZZ=1:1 S LRRLROC=$P(LRRLST,";",LRRZZ) Q:LRRLROC=""  S LRRSITE=$P(LRRDLST,";",LRRZZ) D LAB
 D KILL Q
 ;
ALLOC ;Entry point to send lab reports to all locations defined in 
 ;file #64.6 (interim reports) that have a domain name entered.
 ;This requires a field "domain name" being added to #64.6 at 
 ;subscript ^LAB(64.6,D0,0), this is a pointer to the domain file.
 S LRRZZ=0
 F  S LRRZZ=$O(^LAB(64.6,LRRZZ)) Q:'LRRZZ  D
 .S LRRZZ(0)=+$P($G(^LAB(64.6,LRRZZ,0)),U,7)
 .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
 D KILL Q
 ;
KILL ;Cleanup before leaving.
 S:$D(ZTQUEUED) ZTREQ="@"
 K %,%DT,DFN,LRCW,LRDFN,LRDPF,LREND,LRFOOT,LRH,LRHF,LRIDT,LRLAB,LROC
 K LRONESPC,LRONETST,LRSTOP,IOP,X,XMDF,Y,ZZ,LRRDATE,LRRDLST
 K LRRLROC,LRRLST,LRRNAME,LRRNORP,LRRSITE,LRRVDT,LRRZZ,LRRDEV
 D V^LRU,^LRKILL,KILL^XM
 Q
TSK ;Entry point from taskman to load a spool file into message.
 ;Enter with XMSUB=header,XMY(SENDEE NAMES)=""
 ;LRRNAME=name of spool document file to load into message.
 K DIC S:'$D(DTIME) DTIME=300
 S U="^",X=LRRNAME,DIC=3.51,DIC(0)="MZ"
 D ^DIC Q:Y<1  S DA=+Y,ZISPL0=Y(0),ZISDA=DA K DIC
DQMAIL W:'$D(ZTQUEUED) !,"Moving it..."
 S XS=$P(ZISPL0,"^",10),XMY(DUZ)="",XMTEXT="^XMBS(3.519,"_XS_",2,"
 D:XS>0 ^XMD D DSDOC^ZISPL(ZISDA),DSD^ZISPL(XS) W:'$D(ZTQUEUED) !,"  Now a normal mail message.."
 I $G(XMZ) S XMDUZ=DUZ D NNEW^XMA ;Make message new for recipient.
 D KILL1 Q
 ;
PRINT ;Entry point from menu option to extract text of message and print it.
 D HOME^%ZIS K DIC
ASK ;Select the mailman basket.
 S DIC="^XMB(3.7,DUZ,2,",DIC(0)="AEMNQ",DIC("A")="Select Mail Basket: "
 S DIC("B")="IN"
 W ! D ^DIC G:Y<1 KILL1 S LRRMK=+Y,LRRMKN=$P(Y,"^",2)
 K ^TMP($J) S (LRRMC,LRRMZ1)=0
 F  S LRRMZ1=$O(^XMB(3.7,DUZ,2,LRRMK,1,LRRMZ1)) Q:LRRMZ1<1  D
 .S J=+^(LRRMZ1,0)
 .Q:$P($G(^XMB(3.9,J,0)),U,1)'["LAB REPORT"
 .S LRRMC=LRRMC+1,^TMP($J,"B",LRRMC)=J
 W "  ",$S(LRRMC=0:"No Lab",1:LRRMC)," Message",$S(LRRMC'=1:"s",1:"")," in basket." G:LRRMC=0 ASK
LIST ;Select the message.
 W @IOF,!,"Select from the following:" S (LRRMZ,LRROUT,I)=0
 F  S I=$O(^TMP($J,"B",I)) Q:'I  S LRRMZ=^TMP($J,"B",I) D  Q:LRROUT
 .I $Y>(IOSL-5) K DIR S DIR(0)="E" D ^DIR K DIR S LRROUT=Y-1 W @IOF Q:LRROUT
 .S LRRMR=$G(^XMB(3.9,LRRMZ,0)) Q:LRRMR=""  S LRRMSUB=$P(LRRMR,U,1)
 .I LRRMSUB["~U~" F  S LRRMSUB=$P(LRRMSUB,"~U~",1)_"^"_$P(LRRMSUB,"~U~",2,99) Q:LRRMSUB'["~U~" 
 .W !,I," Subj: ",LRRMSUB,"  "
 .S Y=$P(LRRMR,U,3),X1=+$P($G(^XMB(3.9,LRRMZ,2,0)),"^",4)
 .I Y'?7N.E W Y
 .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)
 .W "  ",X1," Line",$S(X1>1:"s",1:"")
 Q:LRROUT
 K DIR S DIR(0)="NO^1:"_LRRMC_":0"
 S DIR("A")="Select Message to Extract",DIR("B")=1
 S DIR("?")="Enter the number of the message you want printed"
 D ^DIR K DIR G:$D(DIRUT) ASK S LRRMZ=$G(^TMP($J,"B",Y))
 S %IS="Q" D ^%ZIS I POP D HOME^%ZIS,KILL1 Q
 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
 D WRITE,KILL1 G ASK
 ;
WRITE ;Print the text of the message.
 U IO S LRRCN=.9999
 F  S LRRCN=$O(^XMB(3.9,LRRMZ,2,LRRCN)) Q:'LRRCN  S X=^(LRRCN,0) W:X="|TOP|" @IOF W:X'="|TOP|" X,!
 W @IOF D ^%ZISC,KILL1 S:$D(ZTQUEUED) ZTREQ="@" Q
 ;
KILL1 K ^TMP($J),LRRCN,LRRMC,LRRMK,LRRMKN,LRRMR,LRRMZ,LRRMZ1
 K LRRMSUB,LRROUT,%,%IS,DA,DIC,DIR,DIROUT,DIRUT,DUOUT,I,J
 K POP,X,X1,XMZ,XS,Y,ZISDA,ZISPL0
 Q