LRAPTIUP ;VA/DALOI/CKA - API Print AP Reports from TIU;09/05/2001
;;5.2;LAB SERVICE;**1030,1031**;NOV 1, 1997;Build 188
;
;;VA LR Patche(s): 259,315
;
;Reference to TGET^TIUSRVR1 supported by IA #2944
; This API is used to extract Anatomic Pathology reports that have
; been stored in TIU and print them.
;
;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
;
K ^TMP("LRTIU",$J),^TMP("LRTIUTXT",$J)
N LRCNT,LRCNTT,LROR,LRFLG,LRTXT,LRHFLG,LRCNTF,LRVAL
S LRDEV=+$G(LRDEV)
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"))
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") D
..Q:IOST["BROWSER"
..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) 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
LRAPTIUP ;VA/DALOI/CKA - API Print AP Reports from TIU;09/05/2001
+1 ;;5.2;LAB SERVICE;**1030,1031**;NOV 1, 1997;Build 188
+2 ;
+3 ;;VA LR Patche(s): 259,315
+4 ;
+5 ;Reference to TGET^TIUSRVR1 supported by IA #2944
+6 ; This API is used to extract Anatomic Pathology reports that have
+7 ; been stored in TIU and print them.
+8 ;
+9 ;Reference to EXTRACT^TIULQ supported by IA #2693
+10 ;
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 KILL ^TMP("LRTIU",$JOB),^TMP("LRTIUTXT",$JOB)
+7 NEW LRCNT,LRCNTT,LROR,LRFLG,LRTXT,LRHFLG,LRCNTF,LRVAL
+8 SET LRDEV=+$GET(LRDEV)
+9 SET LRQUIT=0
+10 IF '$GET(LRTIUDA)
Begin DoDot:1
+11 WRITE $CHAR(7),!,"The IEN from the TIU DOCUMENT (#8925) file is undefined.",!
End DoDot:1
QUIT
+12 DO EXTRACT
+13 IF LRQUIT
DO END
QUIT
+14 DO DISSECT
+15 IF LRQUIT
DO END
QUIT
+16 IF LRDEV
DO ASKDEV
+17 IF $GET(POP)!LRQUIT
DO END
QUIT
+18 DO REPORT
+19 DO END
+20 QUIT
+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
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
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
REPORT ;
+1 USE IO
IF IOST?1"C-".E
WRITE @IOF
+2 NEW LRPG,LRHDC,LRFTC,LRTXC,LRTOTPGS,LROR1,LROR2,LREND
+3 SET (LRQUIT,LRPG,LREND)=0
+4 SET LRHDC=+$GET(^TMP("LRTIUTXT",$JOB,"HDR"))
+5 SET LRFTC=+$GET(^TMP("LRTIUTXT",$JOB,"FTR"))
+6 SET LRTXC=+$GET(^TMP("LRTIUTXT",$JOB,"TEXT"))
+7 SET LRTOTPGS=LRTXC\(IOSL-LRHDC-LRFTC-4)
+8 IF LRTXC#(IOSL-LRHDC-LRFTC-4)
SET LRTOTPGS=LRTOTPGS+1
+9 DO HEADER
+10 IF LRQUIT
QUIT
+11 ;Calculate LR and TIU checksums, if they don't match, set flag
+12 ; to scramble signature on the report.
+13 DO CHKSUM
+14 IF LRCKSUM'=0
IF LRCKSUM'=TIUCKSUM
SET LRENCRYP=1
+15 DO BODY
+16 IF LRQUIT
QUIT
+17 SET LREND=1
+18 DO FOOTER
+19 QUIT
+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
FOR
SET LROR=$ORDER(^TMP("LRTIUTXT",$JOB,"HDR",LROR))
IF LROR'>0
QUIT
Begin DoDot:1
+7 SET LRTXT=$GET(^TMP("LRTIUTXT",$JOB,"HDR",LROR))
+8 WRITE LRTXT
+9 IF LRTXT["MEDICAL RECORD"!(LRTXT["AUTOPSY PROTOCOL")
Begin DoDot:2
+10 IF IOST["BROWSER"
QUIT
+11 WRITE ?68,"Pg",$JUSTIFY(LRPG,3)," of ",LRTOTPGS
End DoDot:2
+12 WRITE !
End DoDot:1
+13 QUIT
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)
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
+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
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
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
