LRAPTIUP.m

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

EXTRACT ;Extract the report from TIU

 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

HEADER ;Report Header

 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

FOOTER ;Report Footer

 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 

EXTRACT   ;Extract the report from TIU

 +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 

HEADER    ;Report Header

 +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 

FOOTER    ;Report Footer

 +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