source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRCAPAM4.m@ 1006

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

initial load of WorldVistAEHR

File size: 4.9 KB
Line 
1LRCAPAM4 ;SLC/RS/DALISC/FHS - LMIP PHASE 4 BUILD MAILMAN MESSAGES FOR LAB LMIP WORKLOAD TRANS ;8/23/91 1039;
2 ;;5.2;LAB SERVICE;**42,105,119,201**;Sep 27, 1994
3EN ;
4 ;Message size <30K
5 ;Message each institution
6 ;Separate message for each month
7 ;Format: $Institution #^Fx Name
8 ;$$Division #^Fx name $$$Reporting month
9 ;*Workload code^in pat^out pat^other pat^qc^in stats^tot stats^manual input^reffered test
10 ;\Workload code name
11 ;-|treating specialty^count|........
12EN1 ;
13 K ^TMP($J) W @IOF,!!
14 S LINE="PHASE 4 OF LMIP DATA COLLECTION" W !?(IOM-$L(LINE))\2,LINE,!
15 S LINE="You should have already reviewed this LMIP data" W !?(IOM-$L(LINE))\2,LINE,!
16 S LINE="in Phase 3. This option will create 1 or more mail message(s)" W !?(IOM-$L(LINE))\2,LINE,!
17 S LINE="and will send it to you <ONLY>." W !?(IOM-$L(LINE))\2,LINE,!
18 S LINE=" YOU MUST USE THE MAILMAN FUNCTION AND FORWARD THE MESSAGE(S)" W !?(IOM-$L(LINE))\2,LINE,!
19 S LINE="TO AUSTIN DPC TO COMPLETE THE NATIONAL REPORTING PROCESS." W !?(IOM-$L(LINE))\2,LINE,!
20GO ;
21 K DIR S DIR("A")="Wish to continue ",DIR(0)="Y",DIR("B")="NO" D ^DIR G:$D(DIRUT) CLEAN I Y='1 W !!?10,"TO CONTINUE YOU MUST ENTER 'YES' - PROCESS ABORTED",! S LREND=1 G EXIT
22ASK1 ;
23 W !?10,"Device to print processing errors if any are detected.",!
24 K %ZIS,DIR,ZTSK S %ZIS="Q" D ^%ZIS G:POP CLEAN
25 I $D(IO("Q")) S ZTRTN="DQ^LRCAPAM4",ZTIO=ION,ZTDESC="Building LAB LMIP Mail Message",ZTDTH=$H D ^%ZTLOAD W !,$S($G(ZTSK):"Queued to "_ION,1:"Error Not Queued"),! G CLEAN
26 W:$E(IOST)="P" !?5,"This will only take a moment - Please standby ",!
27DQ U IO S:$D(DEQUEUED) ZTREQ="@"
28 K ^TMP($J)
29 W !!?5,"Processing data and building Mailman messages ",!
30 W !?15,$TR($$FMTE^XLFDT($$NOW^XLFDT,"1M"),"@"," "),!
31 S LRCPM=30000,LRLLN=+$G(^LAH("LABWL",0)) I LRLLN
32 E W !!,"No data in global !!",$C(7) G EXIT
33 S LRHD1=$G(^LAH("LABWL",1,0)) D D:$G(LREND) PRINT G:$G(LREND) EXIT
34 . I '$S('$P(LRHD1,"$",2):1,'$P(LRHD1,"$$",2):1,'$P(LRHD1,"$$$",2):1,1:0) S LREND=1 W !!?10,"^LAB(""LABWL"" is corrupt ",!!,$C(7)
35 S LRHD1="",(LRCHC,LRDLN,LRSEQ)=0,LRMSN=1
36 S (LREND,LRSLN)=0 F S LRSLN=$O(^LAH("LABWL",LRSLN)) Q:'LRSLN!($G(LREND)) S LRTXT=^(LRSLN) D LOOP1
37 I '$G(LREND),(LRDLN>2) D NEWMSG
38EXIT ;
39 S LRTXT=$S($G(LREND):"Process Error",1:"Phase 4 Finished") W !?20,LRTXT,!! W:$E(IOST)="P" @IOF W !!,"DONE",!!
40 I IO'=IO(0) U IO(0) W !?20,LRTXT,! U IO
41CLEAN Q:$G(LRDEBUG) K ^TMP($J),DIR,%ZIS D ^%ZISC
42 K LINE,LRCHC,LRCPM,LRDLN,LRDV1,LRDV2,LRDVDT,LREND,LRHD1,LRLLN,LRMSM,LRSLN,LRSUB
43 K LRSEQ,LRCHK,LRX,ZTSK,LRDV1X,LRDV2X
44 K LRTXT,LRX,LRXM,LRX4,LRMSN,XMZ,NODE,X,Y,XMTEXT,XMY,XMSUB,XMDUZ D ^%ZISC
45 Q
46LOOP1 ;
47 I LRSLN=1 S LRDV1=$P($P(LRTXT,"$",2),U),LRDV2=$P($P(LRTXT,"$$",2),U),LRDVDT=$P(LRTXT,"$$$",2),LRHD1=LRTXT,^TMP($J,1,0)=LRHD1,LRDLN=1,LRSEQ=1 Q
48 I $E(LRTXT)="$" D:LRDV1'=$P($P(LRTXT,"$",2),U)!(LRDV2'=$P($P(LRTXT,"$$",2),U))!(LRDVDT'=$P(LRTXT,"$$$",2)) NEWMSG S LRSEQ=1 Q
49 S LREND=$S('LRDV1:1,'LRDV2:1,'LRDVDT:1,1:0) I LREND W !!?5,"Header Block Corrupted (^LAH(LABWL,"_LRSLN_")",! D PRINT Q
50 S LRX=$E(LRTXT),LRCHK=$S(LRX="$":1,LRX="*":2,LRX="\":3,LRX="-":4,1:0)
51 I 'LRCHK W !!?5,"Starting charater not correct at position "_LRSLN_" ABORTED",!! S LREND=1 D PRINT Q
52 I LRSEQ=0,LRCHK='1 W !!?5," Sequence not correct ^LAB(LABWL,"_LRSLN_")",! S LREND=1 D PRINT Q
53CHK D D:$G(LREND) PRINT Q:$G(LREND)
54 . I LRSEQ=0,LRCHK=1 S LRSEQ=1 Q
55 . I LRSEQ=1,LRCHK=2 S LRSEQ=2 Q
56 . I LRSEQ=2,LRCHK=3 S LRSEQ=3 Q
57 . I LRSEQ=3,LRCHK=4 S LRSEQ=4 Q
58 . I LRSEQ=3,LRCHK=2 S LRSEQ=2 Q
59 . I LRSEQ=4,LRCHK=4 Q
60 . I LRSEQ=4,"12"[LRCHK S LRSEQ=LRCHK Q
61 . W !!,"Data is not in proper sequence [Error = ^LAB(LABWL,"_LRSLN_")"
62 . S LREND=1
63 I $E(LRTXT)="*",((LRCHC+$L(LRTXT))>LRCPM) S:$D(^TMP($J,1,0)) LRHD1=^(0) D NEWMSG S LRSEQ=2
64 S LRDLN=LRDLN+1,^TMP($J,LRDLN,0)=LRTXT,LRCHC=LRCHC+$L(LRTXT)+1
65 W:'(LRDLN#5) "."
66 Q
67NEWMSG ;
68 I LRMSN D MAIL W:'$G(LREND) !,"LMIP Message #",LRMSN," filed !!",!
69 K ^TMP($J)
70 S LRMSN=LRMSN+1,(LRDLN,LRSEQ)=1,LRCHC=0
71 I $E(LRTXT)="$" S LRHD1=LRTXT,LRDV1=$P($P(LRHD1,"$",2),U),LRDV2=$P($P(LRHD1,"$$",2),U),LRDVDT=$P(LRHD1,"$$$",2)
72 S ^TMP($J,1,0)=LRHD1
73 Q
74MAIL ;
75 S (LRSUB,XMSUB)="LMIP WKL Msg #"_LRMSN_" D/I "_$P($P(LRHD1,"$$",2),U)_"/"_$P($P(LRHD1,"$",2),U)_" "_$$FMTE^XLFDT($P(LRHD1,"$$$",2),"1D")
76 S XMDUZ=DUZ,XMTEXT="^TMP("_$J_",",XMY(+$G(DUZ))=""
77 D ^XMD I '$G(XMZ) W !!?4,"Error in the call to Mailman",! S LREND=1 Q
78 W !,LRSUB,!,"Mailman message number ",XMZ
79 S LRDV1X=$O(^DIC(4,"D",LRDV1,0)),LRDV2X=$O(^DIC(4,"D",LRDV2,0))
80 I $S('LRDV2X:1,'LRDV1X:1,1:0) D ERR Q
81 S NODE=$O(^LRO(67.9,LRDV1X,1,LRDV2X,1,"B",+LRDVDT,0)) D:'NODE ERR Q:'NODE S LRXM=$G(^LRO(67.9,LRDV1X,1,LRDV2X,1,NODE,0)) D:'LRXM ERR I NODE,LRXM D
82 . S LRX4=$P(LRXM,U,4) S:'$L(LRX4) $P(LRXM,U,4)=XMZ S:$L(LRX4) $P(LRXM,U,4)=$E(XMZ_":"_LRX4,1,50)
83 . S ^LRO(67.9,LRDV1X,1,LRDV2X,1,NODE,0)=LRXM
84 Q
85ERR ;
86 W !!?10,"UNABLE TO STORE MESSAGE NUMBER IN ^LRO(67.9 FILE",!! Q
87PRINT ;
88 N X,I
89 W !!?5,"Error at subscript < "_LRSLN_" >",!,"Listing of surrounding data",!!
90 S I=0 S:$G(LRSLN)>5 I=(LRSLN-5) F X=1:1:10 S I=$O(^LAH("LABWL",I)) Q:I<1 W !,"^LAH(LABWL,",I,") =",!,?6,^(I),!
91 W ! Q
Note: See TracBrowser for help on using the repository browser.