- 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
