- 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 Feb 18, 2025@23:34:24 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