LRAPTIUP ;DALOI/STAFF - API Print AP Reports from TIU ;11/05/10 17:30
;;5.2;LAB SERVICE;**259,315,350**;Sep 27, 1994;Build 230
;
; This API is used to extract Anatomic Pathology reports that have
; been stored in TIU and print them.
;
; Reference to TGET^TIUSRVR1 supported by IA #2944
; Reference to EXTRACT^TIULQ supported by IA #2693
;
MAIN(LRTIUDA,LRDEV) ; Control Branching
;
; LRTIUDA - IEN of document from TIU DOCUMENT (#8925) file
; LRDEV - 1 indicates use device handling in this routine
; 0 indicates use device handling of calling application
;
N LRCNT,LRCNTT,LRCNTF,LRFLG,LRHFLG,LROR,LRPTR,LRTXT,LRVAL
;
K ^TMP("LRTIU",$J),^TMP("LRTIUTXT",$J)
;
S LRDEV=+$G(LRDEV)
S LRPTR=LRTIUDA ; Used below in checking the checksum on document.
S LRQUIT=0
I '$G(LRTIUDA) D Q
. W $C(7),!,"The IEN from the TIU DOCUMENT (#8925) file is undefined.",!
D EXTRACT
I LRQUIT D END Q
D DISSECT
I LRQUIT D END Q
D:LRDEV ASKDEV
I $G(POP)!LRQUIT D END Q
D REPORT
D END
Q
;
;
D EXTRACT^TIULQ(LRTIUDA,"^TMP(""LRTIU"",$J)",,,,1,,1)
I '+$P($G(^TMP("LRTIU",$J,LRTIUDA,"TEXT",0)),"^",3) D Q
. W $C(7),!!,"Document not found.",!
. S LRQUIT=1
M ^TMP("LRTIUTXT",$J)=^TMP("LRTIU",$J,LRTIUDA,"TEXT")
Q
;
;
DISSECT ; Dissect the report into header, body, and footer
S (LROR,LRCNT,LRCNTT,LRHFLG)=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
. . W $C(7),!!,"Document is not an Anatomic Pathology report.",!
. . 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
;
;
ASKDEV ;
W !
S %ZIS="Q" D ^%ZIS
I POP W ! S LRQUIT=1 Q
I $D(IO("Q")) D
.S ZTDESC="Print Anat Path Reports"
.S ZTRTN="REPORT^LRAPTIUP"
.D ^%ZTLOAD W:$D(ZTSK) !,"Request Queued, #",ZTSK W !
.K ZTSK,IO("Q") D HOME^%ZIS
.S LRQUIT=1
Q
;
;
REPORT ;
U IO
W:IOST?1"C-".E @IOF
N LRPG,LRHDC,LRFTC,LRTXC,LRTOTPGS,LROR1,LROR2,LREND
S (LRQUIT,LRPG,LREND)=0
S LRHDC=+$G(^TMP("LRTIUTXT",$J,"HDR"))
S LRFTC=+$G(^TMP("LRTIUTXT",$J,"FTR"))
S LRTXC=+$G(^TMP("LRTIUTXT",$J,"TEXT"))
;
I (IOSL-LRHDC-LRFTC-4)<1 S LRTOTPGS=LRTXC
E S LRTOTPGS=LRTXC\(IOSL-LRHDC-LRFTC-4) S:LRTXC#(IOSL-LRHDC-LRFTC-4) LRTOTPGS=LRTOTPGS+1
;
D HEADER
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 BODY
Q:LRQUIT
S LREND=1
D FOOTER
Q
;
;
I LRPG>0,IOST?1"C-".E D Q:LRQUIT
. K DIR S DIR(0)="E"
. D ^DIR W !
. S:$D(DTOUT)!(X[U) LRQUIT=1
W:LRPG>0 @IOF S LRPG=LRPG+1
S LROR=0
F S LROR=$O(^TMP("LRTIUTXT",$J,"HDR",LROR)) Q:LROR'>0 D
. S LRTXT=$G(^TMP("LRTIUTXT",$J,"HDR",LROR))
. W LRTXT
. I LRTXT["MEDICAL RECORD"!(LRTXT["AUTOPSY PROTOCOL"),$E(IOST,1,2)'="C-" W ?68,"Pg",$J(LRPG,3)," of ",LRTOTPGS
. W !
Q
;
;
BODY ; Body of Report
S LROR1=0
F S LROR1=$O(^TMP("LRTIUTXT",$J,"TEXT",LROR1)) Q:LROR1'>0!(LRQUIT) D
. I $Y>(IOSL-LRFTC-5),$E(IOST,1,2)'="C-" D FOOTER,HEADER Q:LRQUIT
. S LRTXT=$G(^TMP("LRTIUTXT",$J,"TEXT",LROR1))
. I LRTXT["/es/",+$G(LRENCRYP) S LRTXT=$$ENCRYP^XUSRB1(LRTXT)
. W LRTXT,!
Q
;
;
S (LROR2,LRCNTF)=0
I IOSL'>66 F Q:$Y>(IOSL-LRFTC-5) W !
F S LROR2=$O(^TMP("LRTIUTXT",$J,"FTR",LROR2)) Q:LROR2'>0 D
. S LRCNTF=LRCNTF+1
. S LRTXT=$G(^TMP("LRTIUTXT",$J,"FTR",LROR2))
. I LRCNTF=2 D Q
. . I LRTXT'=""&(LRTXT'["(End") W LRTXT,! Q
. . I 'LREND W ?57,"(See next page)",! Q
. . W ?57,"(End of report)",!
. W LRTXT,!
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
;CKA-Calculate checksum of TIU report
S $P(^TMP("LRTIU",$J,LRTIUDA,"TEXT",0),U,5)=$P(^TMP("LRTIU",$J,LRTIUDA,1201,"I"),".")
S LRVAL="^TMP(""LRTIU"","_$J_","_LRTIUDA_",""TEXT"")"
S TIUCKSUM=$$CHKSUM^XUSESIG1(LRVAL)
Q
;
;
END ;
W:IOST?1"P-".E @IOF
I LRDEV D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
K ^TMP("LRTIU",$J),^TMP("LRTIUTXT",$J)
K %,DIR,DTOUT,DUOUT,DIRUT,X,Y
K %ZIS,LRCKSUM,LRENCRYP,LRPTR,POP,TIUCKSUM
K ZTDESC,ZTQUEUED,ZTREQ,ZTRTN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPTIUP 5619 printed Sep 23, 2025@19:44:11 Page 2
LRAPTIUP ;DALOI/STAFF - API Print AP Reports from TIU ;11/05/10 17:30
+1 ;;5.2;LAB SERVICE;**259,315,350**;Sep 27, 1994;Build 230
+2 ;
+3 ; This API is used to extract Anatomic Pathology reports that have
+4 ; been stored in TIU and print them.
+5 ;
+6 ; Reference to TGET^TIUSRVR1 supported by IA #2944
+7 ; Reference to EXTRACT^TIULQ supported by IA #2693
+8 ;
MAIN(LRTIUDA,LRDEV) ; Control Branching
+1 ;
+2 ; LRTIUDA - IEN of document from TIU DOCUMENT (#8925) file
+3 ; LRDEV - 1 indicates use device handling in this routine
+4 ; 0 indicates use device handling of calling application
+5 ;
+6 NEW LRCNT,LRCNTT,LRCNTF,LRFLG,LRHFLG,LROR,LRPTR,LRTXT,LRVAL
+7 ;
+8 KILL ^TMP("LRTIU",$JOB),^TMP("LRTIUTXT",$JOB)
+9 ;
+10 SET LRDEV=+$GET(LRDEV)
+11 ; Used below in checking the checksum on document.
SET LRPTR=LRTIUDA
+12 SET LRQUIT=0
+13 IF '$GET(LRTIUDA)
Begin DoDot:1
+14 WRITE $CHAR(7),!,"The IEN from the TIU DOCUMENT (#8925) file is undefined.",!
End DoDot:1
QUIT
+15 DO EXTRACT
+16 IF LRQUIT
DO END
QUIT
+17 DO DISSECT
+18 IF LRQUIT
DO END
QUIT
+19 if LRDEV
DO ASKDEV
+20 IF $GET(POP)!LRQUIT
DO END
QUIT
+21 DO REPORT
+22 DO END
+23 QUIT
+24 ;
+25 ;
+1 DO EXTRACT^TIULQ(LRTIUDA,"^TMP(""LRTIU"",$J)",,,,1,,1)
+2 IF '+$PIECE($GET(^TMP("LRTIU",$JOB,LRTIUDA,"TEXT",0)),"^",3)
Begin DoDot:1
+3 WRITE $CHAR(7),!!,"Document not found.",!
+4 SET LRQUIT=1
End DoDot:1
QUIT
+5 MERGE ^TMP("LRTIUTXT",$JOB)=^TMP("LRTIU",$JOB,LRTIUDA,"TEXT")
+6 QUIT
+7 ;
+8 ;
DISSECT ; Dissect the report into header, body, and footer
+1 SET (LROR,LRCNT,LRCNTT,LRHFLG)=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 WRITE $CHAR(7),!!,"Document is not an Anatomic Pathology report.",!
+6 SET LRQUIT=1
End DoDot:2
QUIT
+7 IF LRTXT="$APHDR"
Begin DoDot:2
+8 SET LRHFLG=1
+9 KILL ^TMP("LRTIUTXT",$JOB,LROR)
End DoDot:2
QUIT
+10 IF LRFLG="H"
Begin DoDot:2
+11 IF LRTXT="$TEXT"
Begin DoDot:3
+12 SET ^TMP("LRTIUTXT",$JOB,"HDR")=LRCNT
SET LRCNT=0
+13 KILL ^TMP("LRTIUTXT",$JOB,LROR)
+14 SET LRFLG="T"
SET LRCNT=0
End DoDot:3
QUIT
+15 if LRFLG="T"
QUIT
+16 SET LRCNT=LRCNT+1
SET LRCNTT=LRCNTT+1
+17 SET ^TMP("LRTIUTXT",$JOB,"HDR",LRCNT)=LRTXT
+18 KILL ^TMP("LRTIUTXT",$JOB,LROR)
End DoDot:2
if LRFLG="T"
QUIT
+19 IF LRFLG="T"
Begin DoDot:2
+20 IF LRTXT="$FTR"
Begin DoDot:3
+21 SET ^TMP("LRTIUTXT",$JOB,"TEXT")=LRCNT
SET LRCNT=0
+22 KILL ^TMP("LRTIUTXT",$JOB,LROR)
+23 SET LRFLG="F"
End DoDot:3
if LRFLG="F"
QUIT
+24 if LRFLG="F"
QUIT
+25 SET LRCNT=LRCNT+1
SET LRCNTT=LRCNTT+1
+26 SET ^TMP("LRTIUTXT",$JOB,"TEXT",LRCNT)=LRTXT
+27 KILL ^TMP("LRTIUTXT",$JOB,LROR)
End DoDot:2
if LRFLG="F"
QUIT
+28 IF LRFLG="F"
Begin DoDot:2
+29 SET LRCNT=LRCNT+1
SET LRCNTT=LRCNTT+1
+30 SET ^TMP("LRTIUTXT",$JOB,"FTR",LRCNT)=LRTXT
+31 KILL ^TMP("LRTIUTXT",$JOB,LROR)
End DoDot:2
End DoDot:1
+32 SET ^TMP("LRTIUTXT",$JOB,"FTR")=LRCNT
+33 SET ^TMP("LRTIUTXT",$JOB,0)=LRCNTT
+34 QUIT
+35 ;
+36 ;
ASKDEV ;
+1 WRITE !
+2 SET %ZIS="Q"
DO ^%ZIS
+3 IF POP
WRITE !
SET LRQUIT=1
QUIT
+4 IF $DATA(IO("Q"))
Begin DoDot:1
+5 SET ZTDESC="Print Anat Path Reports"
+6 SET ZTRTN="REPORT^LRAPTIUP"
+7 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Request Queued, #",ZTSK
WRITE !
+8 KILL ZTSK,IO("Q")
DO HOME^%ZIS
+9 SET LRQUIT=1
End DoDot:1
+10 QUIT
+11 ;
+12 ;
REPORT ;
+1 USE IO
+2 if IOST?1"C-".E
WRITE @IOF
+3 NEW LRPG,LRHDC,LRFTC,LRTXC,LRTOTPGS,LROR1,LROR2,LREND
+4 SET (LRQUIT,LRPG,LREND)=0
+5 SET LRHDC=+$GET(^TMP("LRTIUTXT",$JOB,"HDR"))
+6 SET LRFTC=+$GET(^TMP("LRTIUTXT",$JOB,"FTR"))
+7 SET LRTXC=+$GET(^TMP("LRTIUTXT",$JOB,"TEXT"))
+8 ;
+9 IF (IOSL-LRHDC-LRFTC-4)<1
SET LRTOTPGS=LRTXC
+10 IF '$TEST
SET LRTOTPGS=LRTXC\(IOSL-LRHDC-LRFTC-4)
if LRTXC#(IOSL-LRHDC-LRFTC-4)
SET LRTOTPGS=LRTOTPGS+1
+11 ;
+12 DO HEADER
+13 if LRQUIT
QUIT
+14 ;
+15 ; Calculate LR and TIU checksums, if they don't match, set flag to scramble signature on the report.
+16 DO CHKSUM
+17 IF LRCKSUM'=0
IF LRCKSUM'=TIUCKSUM
SET LRENCRYP=1
+18 ;
+19 DO BODY
+20 if LRQUIT
QUIT
+21 SET LREND=1
+22 DO FOOTER
+23 QUIT
+24 ;
+25 ;
+1 IF LRPG>0
IF IOST?1"C-".E
Begin DoDot:1
+2 KILL DIR
SET DIR(0)="E"
+3 DO ^DIR
WRITE !
+4 if $DATA(DTOUT)!(X[U)
SET LRQUIT=1
End DoDot:1
if LRQUIT
QUIT
+5 if LRPG>0
WRITE @IOF
SET LRPG=LRPG+1
+6 SET LROR=0
+7 FOR
SET LROR=$ORDER(^TMP("LRTIUTXT",$JOB,"HDR",LROR))
if LROR'>0
QUIT
Begin DoDot:1
+8 SET LRTXT=$GET(^TMP("LRTIUTXT",$JOB,"HDR",LROR))
+9 WRITE LRTXT
+10 IF LRTXT["MEDICAL RECORD"!(LRTXT["AUTOPSY PROTOCOL")
IF $EXTRACT(IOST,1,2)'="C-"
WRITE ?68,"Pg",$JUSTIFY(LRPG,3)," of ",LRTOTPGS
+11 WRITE !
End DoDot:1
+12 QUIT
+13 ;
+14 ;
BODY ; Body of Report
+1 SET LROR1=0
+2 FOR
SET LROR1=$ORDER(^TMP("LRTIUTXT",$JOB,"TEXT",LROR1))
if LROR1'>0!(LRQUIT)
QUIT
Begin DoDot:1
+3 IF $Y>(IOSL-LRFTC-5)
IF $EXTRACT(IOST,1,2)'="C-"
DO FOOTER
DO HEADER
if LRQUIT
QUIT
+4 SET LRTXT=$GET(^TMP("LRTIUTXT",$JOB,"TEXT",LROR1))
+5 IF LRTXT["/es/"
IF +$GET(LRENCRYP)
SET LRTXT=$$ENCRYP^XUSRB1(LRTXT)
+6 WRITE LRTXT,!
End DoDot:1
+7 QUIT
+8 ;
+9 ;
+1 SET (LROR2,LRCNTF)=0
+2 IF IOSL'>66
FOR
if $Y>(IOSL-LRFTC-5)
QUIT
WRITE !
+3 FOR
SET LROR2=$ORDER(^TMP("LRTIUTXT",$JOB,"FTR",LROR2))
if LROR2'>0
QUIT
Begin DoDot:1
+4 SET LRCNTF=LRCNTF+1
+5 SET LRTXT=$GET(^TMP("LRTIUTXT",$JOB,"FTR",LROR2))
+6 IF LRCNTF=2
Begin DoDot:2
+7 IF LRTXT'=""&(LRTXT'["(End")
WRITE LRTXT,!
QUIT
+8 IF 'LREND
WRITE ?57,"(See next page)",!
QUIT
+9 WRITE ?57,"(End of report)",!
End DoDot:2
QUIT
+10 WRITE LRTXT,!
End DoDot:1
+11 QUIT
+12 ;
+13 ;
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 ;CKA-Calculate checksum of TIU report
+18 SET $PIECE(^TMP("LRTIU",$JOB,LRTIUDA,"TEXT",0),U,5)=$PIECE(^TMP("LRTIU",$JOB,LRTIUDA,1201,"I"),".")
+19 SET LRVAL="^TMP(""LRTIU"","_$JOB_","_LRTIUDA_",""TEXT"")"
+20 SET TIUCKSUM=$$CHKSUM^XUSESIG1(LRVAL)
+21 QUIT
+22 ;
+23 ;
END ;
+1 if IOST?1"P-".E
WRITE @IOF
+2 IF LRDEV
DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 KILL ^TMP("LRTIU",$JOB),^TMP("LRTIUTXT",$JOB)
+4 KILL %,DIR,DTOUT,DUOUT,DIRUT,X,Y
+5 KILL %ZIS,LRCKSUM,LRENCRYP,LRPTR,POP,TIUCKSUM
+6 KILL ZTDESC,ZTQUEUED,ZTREQ,ZTRTN
+7 QUIT
