LRCAPAM4.m

LRCAPAM4 ; IHS/DIR/AAB - LMIP PHASE 4 BUILD MAILMAN MESSAGES FOR LAB LMIP WORKLOAD TRANS 8/23/91 1039 ;

 ;;5.2;LR;**1006**;SEP 01, 1998

 ;

 ;;5.2;LAB SERVICE;**42,105,119,201**;Sep 27, 1994

EN ;

 ;Message size <30K

 ;Message each institution

 ;Separate message for each month

 ;Format: $Institution #^Fx Name

 ;$$Division #^Fx name  $$$Reporting month

 ;*Workload code^in pat^out pat^other pat^qc^in stats^tot stats^manual input^reffered test

 ;\Workload code name

 ;-|treating specialty^count|........

EN1 ;

 K ^TMP($J) W @IOF,!!

 S LINE="PHASE 4 OF LMIP DATA COLLECTION" W !?(IOM-$L(LINE))\2,LINE,!

 S LINE="You should have already reviewed this LMIP data" W !?(IOM-$L(LINE))\2,LINE,!

 S LINE="in Phase 3. This option will create 1 or more mail message(s)" W !?(IOM-$L(LINE))\2,LINE,!

 S LINE="and will send it to you <ONLY>." W !?(IOM-$L(LINE))\2,LINE,!

 S LINE="    YOU MUST USE THE MAILMAN FUNCTION AND FORWARD THE MESSAGE(S)" W !?(IOM-$L(LINE))\2,LINE,!

 S LINE="TO AUSTIN DPC TO COMPLETE THE NATIONAL REPORTING PROCESS." W !?(IOM-$L(LINE))\2,LINE,!

GO ;

 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

ASK1 ;

 W !?10,"Device to print processing errors if any are detected.",!

 K %ZIS,DIR,ZTSK S %ZIS="Q" D ^%ZIS G:POP CLEAN

 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

 W:$E(IOST)="P" !?5,"This will only take a moment - Please standby ",!

DQ U IO S:$D(DEQUEUED) ZTREQ="@"

 K ^TMP($J)

 W !!?5,"Processing data and building Mailman messages ",!

 W !?15,$TR($$FMTE^XLFDT($$NOW^XLFDT,"1M"),"@"," "),!

 S LRCPM=30000,LRLLN=+$G(^LAH("LABWL",0)) I LRLLN

 E  W !!,"No data in global !!",$C(7) G EXIT

 S LRHD1=$G(^LAH("LABWL",1,0)) D  D:$G(LREND) PRINT G:$G(LREND) EXIT

 .  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)

 S LRHD1="",(LRCHC,LRDLN,LRSEQ)=0,LRMSN=1

 S (LREND,LRSLN)=0 F  S LRSLN=$O(^LAH("LABWL",LRSLN)) Q:'LRSLN!($G(LREND))  S LRTXT=^(LRSLN) D LOOP1

 I '$G(LREND),(LRDLN>2) D NEWMSG

EXIT ;

 S LRTXT=$S($G(LREND):"Process Error",1:"Phase 4 Finished") W !?20,LRTXT,!! W:$E(IOST)="P" @IOF W !!,"DONE",!!

 I IO'=IO(0) U IO(0) W !?20,LRTXT,! U IO

CLEAN Q:$G(LRDEBUG)  K ^TMP($J),DIR,%ZIS D ^%ZISC

 K LINE,LRCHC,LRCPM,LRDLN,LRDV1,LRDV2,LRDVDT,LREND,LRHD1,LRLLN,LRMSM,LRSLN,LRSUB

 K LRSEQ,LRCHK,LRX,ZTSK,LRDV1X,LRDV2X

 K LRTXT,LRX,LRXM,LRX4,LRMSN,XMZ,NODE,X,Y,XMTEXT,XMY,XMSUB,XMDUZ D ^%ZISC

 Q

LOOP1 ;

 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

 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

 S LREND=$S('LRDV1:1,'LRDV2:1,'LRDVDT:1,1:0) I LREND W !!?5,"Header Block Corrupted (^LAH(LABWL,"_LRSLN_")",! D PRINT Q

 S LRX=$E(LRTXT),LRCHK=$S(LRX="$":1,LRX="*":2,LRX="\":3,LRX="-":4,1:0)

 I 'LRCHK W !!?5,"Starting charater not correct at position "_LRSLN_" ABORTED",!! S LREND=1 D PRINT Q

 I LRSEQ=0,LRCHK='1 W !!?5," Sequence not correct ^LAB(LABWL,"_LRSLN_")",! S LREND=1 D PRINT Q

CHK D  D:$G(LREND) PRINT Q:$G(LREND)

 . I LRSEQ=0,LRCHK=1 S LRSEQ=1 Q

 . I LRSEQ=1,LRCHK=2 S LRSEQ=2 Q

 . I LRSEQ=2,LRCHK=3 S LRSEQ=3 Q

 . I LRSEQ=3,LRCHK=4 S LRSEQ=4 Q

 . I LRSEQ=3,LRCHK=2 S LRSEQ=2 Q

 . I LRSEQ=4,LRCHK=4 Q

 . I LRSEQ=4,"12"[LRCHK S LRSEQ=LRCHK Q

 . W !!,"Data is not in proper sequence [Error = ^LAB(LABWL,"_LRSLN_")"

 . S LREND=1

 I $E(LRTXT)="*",((LRCHC+$L(LRTXT))>LRCPM) S:$D(^TMP($J,1,0)) LRHD1=^(0) D NEWMSG S LRSEQ=2

 S LRDLN=LRDLN+1,^TMP($J,LRDLN,0)=LRTXT,LRCHC=LRCHC+$L(LRTXT)+1

 W:'(LRDLN#5) "."

 Q

NEWMSG ;

 I LRMSN D MAIL W:'$G(LREND) !,"LMIP Message #",LRMSN," filed !!",!

 K ^TMP($J)

 S LRMSN=LRMSN+1,(LRDLN,LRSEQ)=1,LRCHC=0

 I $E(LRTXT)="$" S LRHD1=LRTXT,LRDV1=$P($P(LRHD1,"$",2),U),LRDV2=$P($P(LRHD1,"$$",2),U),LRDVDT=$P(LRHD1,"$$$",2)

 S ^TMP($J,1,0)=LRHD1

 Q

MAIL ;

 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")

 S XMDUZ=DUZ,XMTEXT="^TMP("_$J_",",XMY(+$G(DUZ))=""

 D ^XMD I '$G(XMZ) W !!?4,"Error in the call to Mailman",! S LREND=1 Q

 W !,LRSUB,!,"Mailman message number ",XMZ

 S LRDV1X=$O(^DIC(4,"D",LRDV1,0)),LRDV2X=$O(^DIC(4,"D",LRDV2,0))

 I $S('LRDV2X:1,'LRDV1X:1,1:0) D ERR Q

 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

 . 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)

 . S ^LRO(67.9,LRDV1X,1,LRDV2X,1,NODE,0)=LRXM

 Q

ERR ;

 W !!?10,"UNABLE TO STORE MESSAGE NUMBER IN ^LRO(67.9 FILE",!! Q

PRINT ;

 N X,I

 W !!?5,"Error at subscript < "_LRSLN_" >",!,"Listing of surrounding data",!!

 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),!

  W ! Q

LRCAPAM4  ; IHS/DIR/AAB - LMIP PHASE 4 BUILD MAILMAN MESSAGES FOR LAB LMIP WORKLOAD TRANS 8/23/91 1039 ;

 +1       ;;5.2;LR;**1006**;SEP 01, 1998

 +2       ;

 +3       ;;5.2;LAB SERVICE;**42,105,119,201**;Sep 27, 1994

EN        ;

 +1       ;Message size <30K

 +2       ;Message each institution

 +3       ;Separate message for each month

 +4       ;Format: $Institution #^Fx Name

 +5       ;$$Division #^Fx name  $$$Reporting month

 +6       ;*Workload code^in pat^out pat^other pat^qc^in stats^tot stats^manual input^reffered test

 +7       ;\Workload code name

 +8       ;-|treating specialty^count|........

EN1       ;

 +1        KILL ^TMP($JOB)

           WRITE @IOF,!!

 +2        SET LINE="PHASE 4 OF LMIP DATA COLLECTION"

           WRITE !?(IOM-$LENGTH(LINE))\2,LINE,!

 +3        SET LINE="You should have already reviewed this LMIP data"

           WRITE !?(IOM-$LENGTH(LINE))\2,LINE,!

 +4        SET LINE="in Phase 3. This option will create 1 or more mail message(s)"

           WRITE !?(IOM-$LENGTH(LINE))\2,LINE,!

 +5        SET LINE="and will send it to you <ONLY>."

           WRITE !?(IOM-$LENGTH(LINE))\2,LINE,!

 +6        SET LINE="    YOU MUST USE THE MAILMAN FUNCTION AND FORWARD THE MESSAGE(S)"

           WRITE !?(IOM-$LENGTH(LINE))\2,LINE,!

 +7        SET LINE="TO AUSTIN DPC TO COMPLETE THE NATIONAL REPORTING PROCESS."

           WRITE !?(IOM-$LENGTH(LINE))\2,LINE,!

GO        ;

 +1        KILL DIR

           SET DIR("A")="Wish to continue "

           SET DIR(0)="Y"

           SET DIR("B")="NO"

           DO ^DIR

           IF $DATA(DIRUT)

               GOTO CLEAN

           IF Y='1

               WRITE !!?10,"TO CONTINUE YOU MUST ENTER 'YES' - PROCESS ABORTED",!

               SET LREND=1

               GOTO EXIT

ASK1      ;

 +1        WRITE !?10,"Device to print processing errors if any are detected.",!

 +2        KILL %ZIS,DIR,ZTSK

           SET %ZIS="Q"

           DO ^%ZIS

           IF POP

               GOTO CLEAN

 +3        IF $DATA(IO("Q"))

               SET ZTRTN="DQ^LRCAPAM4"

               SET ZTIO=ION

               SET ZTDESC="Building LAB LMIP Mail Message"

               SET ZTDTH=$HOROLOG

               DO ^%ZTLOAD

               WRITE !,$SELECT($GET(ZTSK):"Queued to "_ION,1:"Error Not Queued"),!

               GOTO CLEAN

 +4        IF $EXTRACT(IOST)="P"

               WRITE !?5,"This will only take a moment - Please standby ",!

DQ         USE IO

           IF $DATA(DEQUEUED)

               SET ZTREQ="@"

 +1        KILL ^TMP($JOB)

 +2        WRITE !!?5,"Processing data and building Mailman messages ",!

 +3        WRITE !?15,$TRANSLATE($$FMTE^XLFDT($$NOW^XLFDT,"1M"),"@"," "),!

 +4        SET LRCPM=30000

           SET LRLLN=+$GET(^LAH("LABWL",0))

           IF LRLLN

 +5       IF '$TEST

               WRITE !!,"No data in global !!",$CHAR(7)

               GOTO EXIT

 +6        SET LRHD1=$GET(^LAH("LABWL",1,0))

           Begin DoDot:1

 +7            IF '$SELECT('$PIECE(LRHD1,"$",2):1,'$PIECE(LRHD1,"$$",2):1,'$PIECE(LRHD1,"$$$",2):1,1:0)

                   SET LREND=1

                   WRITE !!?10,"^LAB(""LABWL"" is corrupt ",!!,$CHAR(7)

           End DoDot:1

           IF $GET(LREND)

               DO PRINT

           IF $GET(LREND)

               GOTO EXIT

 +8        SET LRHD1=""

           SET (LRCHC,LRDLN,LRSEQ)=0

           SET LRMSN=1

 +9        SET (LREND,LRSLN)=0

           FOR 

               SET LRSLN=$ORDER(^LAH("LABWL",LRSLN))

               IF 'LRSLN!($GET(LREND))

                   QUIT 

               SET LRTXT=^(LRSLN)

               DO LOOP1

 +10       IF '$GET(LREND)

               IF (LRDLN>2)

                   DO NEWMSG

EXIT      ;

 +1        SET LRTXT=$SELECT($GET(LREND):"Process Error",1:"Phase 4 Finished")

           WRITE !?20,LRTXT,!!

           IF $EXTRACT(IOST)="P"

               WRITE @IOF

           WRITE !!,"DONE",!!

 +2        IF IO'=IO(0)

               USE IO(0)

               WRITE !?20,LRTXT,!

               USE IO

CLEAN      IF $GET(LRDEBUG)

               QUIT 

           KILL ^TMP($JOB),DIR,%ZIS

           DO ^%ZISC

 +1        KILL LINE,LRCHC,LRCPM,LRDLN,LRDV1,LRDV2,LRDVDT,LREND,LRHD1,LRLLN,LRMSM,LRSLN,LRSUB

 +2        KILL LRSEQ,LRCHK,LRX,ZTSK,LRDV1X,LRDV2X

 +3        KILL LRTXT,LRX,LRXM,LRX4,LRMSN,XMZ,NODE,X,Y,XMTEXT,XMY,XMSUB,XMDUZ

           DO ^%ZISC

 +4        QUIT 

LOOP1     ;

 +1        IF LRSLN=1

               SET LRDV1=$PIECE($PIECE(LRTXT,"$",2),U)

               SET LRDV2=$PIECE($PIECE(LRTXT,"$$",2),U)

               SET LRDVDT=$PIECE(LRTXT,"$$$",2)

               SET LRHD1=LRTXT

               SET ^TMP($JOB,1,0)=LRHD1

               SET LRDLN=1

               SET LRSEQ=1

               QUIT 

 +2        IF $EXTRACT(LRTXT)="$"

               IF LRDV1'=$PIECE($PIECE(LRTXT,"$",2),U)!(LRDV2'=$PIECE($PIECE(LRTXT,"$$",2),U))!(LRDVDT'=$PIECE(LRTXT,"$$$",2))

                   DO NEWMSG

               SET LRSEQ=1

               QUIT 

 +3        SET LREND=$SELECT('LRDV1:1,'LRDV2:1,'LRDVDT:1,1:0)

           IF LREND

               WRITE !!?5,"Header Block Corrupted (^LAH(LABWL,"_LRSLN_")",!

               DO PRINT

               QUIT 

 +4        SET LRX=$EXTRACT(LRTXT)

           SET LRCHK=$SELECT(LRX="$":1,LRX="*":2,LRX="\":3,LRX="-":4,1:0)

 +5        IF 'LRCHK

               WRITE !!?5,"Starting charater not correct at position "_LRSLN_" ABORTED",!!

               SET LREND=1

               DO PRINT

               QUIT 

 +6        IF LRSEQ=0

               IF LRCHK='1

                   WRITE !!?5," Sequence not correct ^LAB(LABWL,"_LRSLN_")",!

                   SET LREND=1

                   DO PRINT

                   QUIT 

CHK        Begin DoDot:1

 +1            IF LRSEQ=0

                   IF LRCHK=1

                       SET LRSEQ=1

                       QUIT 

 +2            IF LRSEQ=1

                   IF LRCHK=2

                       SET LRSEQ=2

                       QUIT 

 +3            IF LRSEQ=2

                   IF LRCHK=3

                       SET LRSEQ=3

                       QUIT 

 +4            IF LRSEQ=3

                   IF LRCHK=4

                       SET LRSEQ=4

                       QUIT 

 +5            IF LRSEQ=3

                   IF LRCHK=2

                       SET LRSEQ=2

                       QUIT 

 +6            IF LRSEQ=4

                   IF LRCHK=4

                       QUIT 

 +7            IF LRSEQ=4

                   IF "12"[LRCHK

                       SET LRSEQ=LRCHK

                       QUIT 

 +8            WRITE !!,"Data is not in proper sequence [Error = ^LAB(LABWL,"_LRSLN_")"

 +9            SET LREND=1

           End DoDot:1

           IF $GET(LREND)

               DO PRINT

           IF $GET(LREND)

               QUIT 

 +10       IF $EXTRACT(LRTXT)="*"

               IF ((LRCHC+$LENGTH(LRTXT))>LRCPM)

                   IF $DATA(^TMP($JOB,1,0))

                       SET LRHD1=^(0)

                   DO NEWMSG

                   SET LRSEQ=2

 +11       SET LRDLN=LRDLN+1

           SET ^TMP($JOB,LRDLN,0)=LRTXT

           SET LRCHC=LRCHC+$LENGTH(LRTXT)+1

 +12       IF '(LRDLN#5)

               WRITE "."

 +13       QUIT 

NEWMSG    ;

 +1        IF LRMSN

               DO MAIL

               IF '$GET(LREND)

                   WRITE !,"LMIP Message #",LRMSN," filed !!",!

 +2        KILL ^TMP($JOB)

 +3        SET LRMSN=LRMSN+1

           SET (LRDLN,LRSEQ)=1

           SET LRCHC=0

 +4        IF $EXTRACT(LRTXT)="$"

               SET LRHD1=LRTXT

               SET LRDV1=$PIECE($PIECE(LRHD1,"$",2),U)

               SET LRDV2=$PIECE($PIECE(LRHD1,"$$",2),U)

               SET LRDVDT=$PIECE(LRHD1,"$$$",2)

 +5        SET ^TMP($JOB,1,0)=LRHD1

 +6        QUIT 

MAIL      ;

 +1        SET (LRSUB,XMSUB)="LMIP WKL Msg #"_LRMSN_" D/I "_$PIECE($PIECE(LRHD1,"$$",2),U)_"/"_$PIECE($PIECE(LRHD1,"$",2),U)_" "_$$FMTE^XLFDT($PIECE(LRHD1,"$$$",2),"1D")

 +2        SET XMDUZ=DUZ

           SET XMTEXT="^TMP("_$JOB_","

           SET XMY(+$GET(DUZ))=""

 +3        DO ^XMD

           IF '$GET(XMZ)

               WRITE !!?4,"Error in the call to Mailman",!

               SET LREND=1

               QUIT 

 +4        WRITE !,LRSUB,!,"Mailman message number ",XMZ

 +5        SET LRDV1X=$ORDER(^DIC(4,"D",LRDV1,0))

           SET LRDV2X=$ORDER(^DIC(4,"D",LRDV2,0))

 +6        IF $SELECT('LRDV2X:1,'LRDV1X:1,1:0)

               DO ERR

               QUIT 

 +7        SET NODE=$ORDER(^LRO(67.9,LRDV1X,1,LRDV2X,1,"B",+LRDVDT,0))

           IF 'NODE

               DO ERR

           IF 'NODE

               QUIT 

           SET LRXM=$GET(^LRO(67.9,LRDV1X,1,LRDV2X,1,NODE,0))

           IF 'LRXM

               DO ERR

           IF NODE

               IF LRXM

                   Begin DoDot:1

 +8                    SET LRX4=$PIECE(LRXM,U,4)

                       IF '$LENGTH(LRX4)

                           SET $PIECE(LRXM,U,4)=XMZ

                       IF $LENGTH(LRX4)

                           SET $PIECE(LRXM,U,4)=$EXTRACT(XMZ_":"_LRX4,1,50)

 +9                    SET ^LRO(67.9,LRDV1X,1,LRDV2X,1,NODE,0)=LRXM

                   End DoDot:1

 +10       QUIT 

ERR       ;

 +1        WRITE !!?10,"UNABLE TO STORE MESSAGE NUMBER IN ^LRO(67.9 FILE",!!

           QUIT 

PRINT     ;

 +1        NEW X,I

 +2        WRITE !!?5,"Error at subscript < "_LRSLN_" >",!,"Listing of surrounding data",!!

 +3        SET I=0

           IF $GET(LRSLN)>5

               SET I=(LRSLN-5)

           FOR X=1:1:10

               SET I=$ORDER(^LAH("LABWL",I))

               IF I<1

                   QUIT 

               WRITE !,"^LAH(LABWL,",I,") =",!,?6,^(I),!

 +4        WRITE !

           QUIT