- 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 Feb 18, 2025@23:31:21 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