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