LRCAPAM4 ;SLC/RS/DALISC/FHS - LMIP PHASE 4 BUILD MAILMAN MESSAGES FOR LAB LMIP WORKLOAD TRANS ;8/23/91 1039;
;;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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRCAPAM4 5153 printed Oct 16, 2024@18:13:24 Page 2
LRCAPAM4 ;SLC/RS/DALISC/FHS - LMIP PHASE 4 BUILD MAILMAN MESSAGES FOR LAB LMIP WORKLOAD TRANS ;8/23/91 1039;
+1 ;;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
