LR7OSAP3 ;DALOI/CKA - Silent AP Rpt from TIU;3/27/02
;;5.2;LAB SERVICE;**259,315**;Sep 27, 1994;Build 25
;
;Reference to EXTRACT^TIULQ supported by IA #2693
;Reference to TGET^TIUSRVR1 supported by IA #2944
;
MAIN(LRPTR) ;Main subrouting
K ^TMP("LRTIU",$J),^TMP("LRTIUTXT",$J)
D EXTRACT
D DISSECT
Q:LRQUIT
;Calculate LR and TIU checksums,if they don't match, set flag
; to scramble signature on the report.
D CHKSUM
I LRCKSUM'=0,LRCKSUM'=TIUCKSUM S LRENCRYP=1
;
D GLOSET
K ^TMP("LRTIU",$J),^TMP("LRTIUTXT",$J)
Q
N LRQUIT,LRFLG,LRTXT,LROR,LRCNT,LRCNTT,LRHFLG
Q:'+$G(LRPTR)
D EXTRACT^TIULQ(LRPTR,"^TMP(""LRTIU"",$J)",,,,1,,1)
Q:'+$P($G(^TMP("LRTIU",$J,LRPTR,"TEXT",0)),"^",3)
M ^TMP("LRTIUTXT",$J)=^TMP("LRTIU",$J,LRPTR,"TEXT")
DISSECT ;Dissect the report into header,body, and footer
S (LROR,LRCNT,LRCNTT,LRHFLG,LRQUIT)=0,LRFLG="H"
F S LROR=$O(^TMP("LRTIUTXT",$J,LROR)) Q:LROR'>0!(LRQUIT) D
.S LRTXT=$G(^TMP("LRTIUTXT",$J,LROR,0))
.I 'LRHFLG,LRTXT'="$APHDR" D Q
..S LRQUIT=1
.I LRTXT="$APHDR" D Q
..S LRHFLG=1
..K ^TMP("LRTIUTXT",$J,LROR)
.I LRFLG="H" D Q:LRFLG="T"
..I LRTXT="$TEXT" D Q
...S ^TMP("LRTIUTXT",$J,"HDR")=LRCNT,LRCNT=0
...K ^TMP("LRTIUTXT",$J,LROR)
...S LRFLG="T",LRCNT=0
..Q:LRFLG="T"
..S LRCNT=LRCNT+1,LRCNTT=LRCNTT+1
..S ^TMP("LRTIUTXT",$J,"HDR",LRCNT)=LRTXT
..K ^TMP("LRTIUTXT",$J,LROR)
.I LRFLG="T" D Q:LRFLG="F"
..I LRTXT="$FTR" D Q:LRFLG="F"
...S ^TMP("LRTIUTXT",$J,"TEXT")=LRCNT,LRCNT=0
...K ^TMP("LRTIUTXT",$J,LROR)
...S LRFLG="F"
..Q:LRFLG="F"
..S LRCNT=LRCNT+1,LRCNTT=LRCNTT+1
..S ^TMP("LRTIUTXT",$J,"TEXT",LRCNT)=LRTXT
..K ^TMP("LRTIUTXT",$J,LROR)
.I LRFLG="F" D
..S LRCNT=LRCNT+1,LRCNTT=LRCNTT+1
..S ^TMP("LRTIUTXT",$J,"FTR",LRCNT)=LRTXT
..K ^TMP("LRTIUTXT",$J,LROR)
S ^TMP("LRTIUTXT",$J,"FTR")=LRCNT
S ^TMP("LRTIUTXT",$J,0)=LRCNTT
Q
GLOSET ;
S LROR=0
Q:'$D(^TMP("LRTIUTXT",$J,"HDR"))
S LROR=0 F S LROR=$O(^TMP("LRTIUTXT",$J,"HDR",LROR)) Q:LROR'>0 D
.S LRTXT=$G(^TMP("LRTIUTXT",$J,"HDR",LROR))
.D LN S ^TMP("LRC",$J,GCNT,0)=LRTXT
Q:'$D(^TMP("LRTIUTXT",$J,"TEXT"))
S LROR=0
F S LROR=$O(^TMP("LRTIUTXT",$J,"TEXT",LROR)) Q:LROR'>0!(LRQUIT) D
.S LRTXT=$G(^TMP("LRTIUTXT",$J,"TEXT",LROR))
.;If signature line, and marked for encryption, scramble signature
.I LRTXT["/es/",+$G(LRENCRYP) S LRTXT=$$ENCRYP^XUSRB1(LRTXT)
.D LN S ^TMP("LRC",$J,GCNT,0)=LRTXT
Q:'$D(^TMP("LRTIUTXT",$J,"FTR"))
S LROR=0
F S LROR=$O(^TMP("LRTIUTXT",$J,"FTR",LROR)) Q:LROR'>0 D
.S LRTXT=$G(^TMP("LRTIUTXT",$J,"FTR",LROR))
.D LN S ^TMP("LRC",$J,GCNT,0)=LRTXT
Q
LN ;Increment the counter
S GCNT=GCNT+1,CCNT=1
Q
CHKSUM ;Compare LR and TIU checksums
;Get original checksum value from file 63
N LRTREC,LRROOT,LRFILE,LRIENS,LRFLD,LRREL
S (LRENCRYP,LRTREC)=0
I LRSS="AU" D
.S LRTREC=$O(^LR(LRDFN,101,"C",LRPTR,LRTREC))
.S LRIENS=LRDFN_","
.S LRFILE=63.101
I LRSS'="AU" D
.S LRTREC=$O(^LR(LRDFN,LRSS,LRI,.05,"C",LRPTR,LRTREC))
.S LRIENS=LRI_","_LRDFN_","
.S LRFILE=$S(LRSS="SP":63.19,LRSS="CY":63.47,LRSS="EM":63.49,1:"")
I LRFILE=""!(LRTREC=0) S LRCKSUM=0 Q
;Retrieve LR checksum
S LRIENS=LRTREC_","_LRIENS
S LRCKSUM=$$GET1^DIQ(LRFILE,LRIENS,2)
I LRCKSUM="" S LRCKSUM=0
;Calculate TIU checksum
S $P(^TMP("LRTIU",$J,LRPTR,"TEXT",0),U,5)=$P(^TMP("LRTIU",$J,LRPTR,1201,"I"),".")
S LRVAL="^TMP(""LRTIU"","_$J_","_LRPTR_",""TEXT"")"
S TIUCKSUM=$$CHKSUM^XUSESIG1(LRVAL)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7OSAP3 3505 printed Oct 16, 2024@18:06:13 Page 2
LR7OSAP3 ;DALOI/CKA - Silent AP Rpt from TIU;3/27/02
+1 ;;5.2;LAB SERVICE;**259,315**;Sep 27, 1994;Build 25
+2 ;
+3 ;Reference to EXTRACT^TIULQ supported by IA #2693
+4 ;Reference to TGET^TIUSRVR1 supported by IA #2944
+5 ;
MAIN(LRPTR) ;Main subrouting
+1 KILL ^TMP("LRTIU",$JOB),^TMP("LRTIUTXT",$JOB)
+2 DO EXTRACT
+3 DO DISSECT
+4 if LRQUIT
QUIT
+5 ;Calculate LR and TIU checksums,if they don't match, set flag
+6 ; to scramble signature on the report.
+7 DO CHKSUM
+8 IF LRCKSUM'=0
IF LRCKSUM'=TIUCKSUM
SET LRENCRYP=1
+9 ;
+10 DO GLOSET
+11 KILL ^TMP("LRTIU",$JOB),^TMP("LRTIUTXT",$JOB)
+12 QUIT
+1 NEW LRQUIT,LRFLG,LRTXT,LROR,LRCNT,LRCNTT,LRHFLG
+2 if '+$GET(LRPTR)
QUIT
+3 DO EXTRACT^TIULQ(LRPTR,"^TMP(""LRTIU"",$J)",,,,1,,1)
+4 if '+$PIECE($GET(^TMP("LRTIU",$JOB,LRPTR,"TEXT",0)),"^",3)
QUIT
+5 MERGE ^TMP("LRTIUTXT",$JOB)=^TMP("LRTIU",$JOB,LRPTR,"TEXT")
DISSECT ;Dissect the report into header,body, and footer
+1 SET (LROR,LRCNT,LRCNTT,LRHFLG,LRQUIT)=0
SET LRFLG="H"
+2 FOR
SET LROR=$ORDER(^TMP("LRTIUTXT",$JOB,LROR))
if LROR'>0!(LRQUIT)
QUIT
Begin DoDot:1
+3 SET LRTXT=$GET(^TMP("LRTIUTXT",$JOB,LROR,0))
+4 IF 'LRHFLG
IF LRTXT'="$APHDR"
Begin DoDot:2
+5 SET LRQUIT=1
End DoDot:2
QUIT
+6 IF LRTXT="$APHDR"
Begin DoDot:2
+7 SET LRHFLG=1
+8 KILL ^TMP("LRTIUTXT",$JOB,LROR)
End DoDot:2
QUIT
+9 IF LRFLG="H"
Begin DoDot:2
+10 IF LRTXT="$TEXT"
Begin DoDot:3
+11 SET ^TMP("LRTIUTXT",$JOB,"HDR")=LRCNT
SET LRCNT=0
+12 KILL ^TMP("LRTIUTXT",$JOB,LROR)
+13 SET LRFLG="T"
SET LRCNT=0
End DoDot:3
QUIT
+14 if LRFLG="T"
QUIT
+15 SET LRCNT=LRCNT+1
SET LRCNTT=LRCNTT+1
+16 SET ^TMP("LRTIUTXT",$JOB,"HDR",LRCNT)=LRTXT
+17 KILL ^TMP("LRTIUTXT",$JOB,LROR)
End DoDot:2
if LRFLG="T"
QUIT
+18 IF LRFLG="T"
Begin DoDot:2
+19 IF LRTXT="$FTR"
Begin DoDot:3
+20 SET ^TMP("LRTIUTXT",$JOB,"TEXT")=LRCNT
SET LRCNT=0
+21 KILL ^TMP("LRTIUTXT",$JOB,LROR)
+22 SET LRFLG="F"
End DoDot:3
if LRFLG="F"
QUIT
+23 if LRFLG="F"
QUIT
+24 SET LRCNT=LRCNT+1
SET LRCNTT=LRCNTT+1
+25 SET ^TMP("LRTIUTXT",$JOB,"TEXT",LRCNT)=LRTXT
+26 KILL ^TMP("LRTIUTXT",$JOB,LROR)
End DoDot:2
if LRFLG="F"
QUIT
+27 IF LRFLG="F"
Begin DoDot:2
+28 SET LRCNT=LRCNT+1
SET LRCNTT=LRCNTT+1
+29 SET ^TMP("LRTIUTXT",$JOB,"FTR",LRCNT)=LRTXT
+30 KILL ^TMP("LRTIUTXT",$JOB,LROR)
End DoDot:2
End DoDot:1
+31 SET ^TMP("LRTIUTXT",$JOB,"FTR")=LRCNT
+32 SET ^TMP("LRTIUTXT",$JOB,0)=LRCNTT
+33 QUIT
GLOSET ;
+1 SET LROR=0
+2 if '$DATA(^TMP("LRTIUTXT",$JOB,"HDR"))
QUIT
+3 SET LROR=0
FOR
SET LROR=$ORDER(^TMP("LRTIUTXT",$JOB,"HDR",LROR))
if LROR'>0
QUIT
Begin DoDot:1
+4 SET LRTXT=$GET(^TMP("LRTIUTXT",$JOB,"HDR",LROR))
+5 DO LN
SET ^TMP("LRC",$JOB,GCNT,0)=LRTXT
End DoDot:1
+6 if '$DATA(^TMP("LRTIUTXT",$JOB,"TEXT"))
QUIT
+7 SET LROR=0
+8 FOR
SET LROR=$ORDER(^TMP("LRTIUTXT",$JOB,"TEXT",LROR))
if LROR'>0!(LRQUIT)
QUIT
Begin DoDot:1
+9 SET LRTXT=$GET(^TMP("LRTIUTXT",$JOB,"TEXT",LROR))
+10 ;If signature line, and marked for encryption, scramble signature
+11 IF LRTXT["/es/"
IF +$GET(LRENCRYP)
SET LRTXT=$$ENCRYP^XUSRB1(LRTXT)
+12 DO LN
SET ^TMP("LRC",$JOB,GCNT,0)=LRTXT
End DoDot:1
+13 if '$DATA(^TMP("LRTIUTXT",$JOB,"FTR"))
QUIT
+14 SET LROR=0
+15 FOR
SET LROR=$ORDER(^TMP("LRTIUTXT",$JOB,"FTR",LROR))
if LROR'>0
QUIT
Begin DoDot:1
+16 SET LRTXT=$GET(^TMP("LRTIUTXT",$JOB,"FTR",LROR))
+17 DO LN
SET ^TMP("LRC",$JOB,GCNT,0)=LRTXT
End DoDot:1
+18 QUIT
LN ;Increment the counter
+1 SET GCNT=GCNT+1
SET CCNT=1
+2 QUIT
CHKSUM ;Compare LR and TIU checksums
+1 ;Get original checksum value from file 63
+2 NEW LRTREC,LRROOT,LRFILE,LRIENS,LRFLD,LRREL
+3 SET (LRENCRYP,LRTREC)=0
+4 IF LRSS="AU"
Begin DoDot:1
+5 SET LRTREC=$ORDER(^LR(LRDFN,101,"C",LRPTR,LRTREC))
+6 SET LRIENS=LRDFN_","
+7 SET LRFILE=63.101
End DoDot:1
+8 IF LRSS'="AU"
Begin DoDot:1
+9 SET LRTREC=$ORDER(^LR(LRDFN,LRSS,LRI,.05,"C",LRPTR,LRTREC))
+10 SET LRIENS=LRI_","_LRDFN_","
+11 SET LRFILE=$SELECT(LRSS="SP":63.19,LRSS="CY":63.47,LRSS="EM":63.49,1:"")
End DoDot:1
+12 IF LRFILE=""!(LRTREC=0)
SET LRCKSUM=0
QUIT
+13 ;Retrieve LR checksum
+14 SET LRIENS=LRTREC_","_LRIENS
+15 SET LRCKSUM=$$GET1^DIQ(LRFILE,LRIENS,2)
+16 IF LRCKSUM=""
SET LRCKSUM=0
+17 ;Calculate TIU checksum
+18 SET $PIECE(^TMP("LRTIU",$JOB,LRPTR,"TEXT",0),U,5)=$PIECE(^TMP("LRTIU",$JOB,LRPTR,1201,"I"),".")
+19 SET LRVAL="^TMP(""LRTIU"","_$JOB_","_LRPTR_",""TEXT"")"
+20 SET TIUCKSUM=$$CHKSUM^XUSESIG1(LRVAL)
+21 QUIT
