Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRAPTIUP

LRAPTIUP.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; This API is used to extract Anatomic Pathology reports that have
  1. ; been stored in TIU and print them.
  1. ;
  1. ; Reference to TGET^TIUSRVR1 supported by IA #2944
  1. ; Reference to EXTRACT^TIULQ supported by IA #2693
  1. ;
  1. MAIN(LRTIUDA,LRDEV) ; Control Branching
  1. ;
  1. ; LRTIUDA - IEN of document from TIU DOCUMENT (#8925) file
  1. ; LRDEV - 1 indicates use device handling in this routine
  1. ; 0 indicates use device handling of calling application
  1. ;
  1. N LRCNT,LRCNTT,LRCNTF,LRFLG,LRHFLG,LROR,LRPTR,LRTXT,LRVAL
  1. ;
  1. K ^TMP("LRTIU",$J),^TMP("LRTIUTXT",$J)
  1. ;
  1. S LRDEV=+$G(LRDEV)
  1. S LRPTR=LRTIUDA ; Used below in checking the checksum on document.
  1. S LRQUIT=0
  1. I '$G(LRTIUDA) D Q
  1. . W $C(7),!,"The IEN from the TIU DOCUMENT (#8925) file is undefined.",!
  1. D EXTRACT
  1. I LRQUIT D END Q
  1. D DISSECT
  1. I LRQUIT D END Q
  1. D:LRDEV ASKDEV
  1. I $G(POP)!LRQUIT D END Q
  1. D REPORT
  1. D END
  1. Q
  1. ;
  1. ;
  1. EXTRACT ; Extract the report from TIU
  1. D EXTRACT^TIULQ(LRTIUDA,"^TMP(""LRTIU"",$J)",,,,1,,1)
  1. I '+$P($G(^TMP("LRTIU",$J,LRTIUDA,"TEXT",0)),"^",3) D Q
  1. . W $C(7),!!,"Document not found.",!
  1. . S LRQUIT=1
  1. M ^TMP("LRTIUTXT",$J)=^TMP("LRTIU",$J,LRTIUDA,"TEXT")
  1. Q
  1. ;
  1. ;
  1. DISSECT ; Dissect the report into header, body, and footer
  1. S (LROR,LRCNT,LRCNTT,LRHFLG)=0,LRFLG="H"
  1. F S LROR=$O(^TMP("LRTIUTXT",$J,LROR)) Q:LROR'>0!(LRQUIT) D
  1. . S LRTXT=$G(^TMP("LRTIUTXT",$J,LROR,0))
  1. . I 'LRHFLG,LRTXT'="$APHDR" D Q
  1. . . W $C(7),!!,"Document is not an Anatomic Pathology report.",!
  1. . . S LRQUIT=1
  1. . I LRTXT="$APHDR" D Q
  1. . . S LRHFLG=1
  1. . . K ^TMP("LRTIUTXT",$J,LROR)
  1. . I LRFLG="H" D Q:LRFLG="T"
  1. . . I LRTXT="$TEXT" D Q
  1. . . . S ^TMP("LRTIUTXT",$J,"HDR")=LRCNT,LRCNT=0
  1. . . . K ^TMP("LRTIUTXT",$J,LROR)
  1. . . . S LRFLG="T",LRCNT=0
  1. . . Q:LRFLG="T"
  1. . . S LRCNT=LRCNT+1,LRCNTT=LRCNTT+1
  1. . . S ^TMP("LRTIUTXT",$J,"HDR",LRCNT)=LRTXT
  1. . . K ^TMP("LRTIUTXT",$J,LROR)
  1. . I LRFLG="T" D Q:LRFLG="F"
  1. . . I LRTXT="$FTR" D Q:LRFLG="F"
  1. . . . S ^TMP("LRTIUTXT",$J,"TEXT")=LRCNT,LRCNT=0
  1. . . . K ^TMP("LRTIUTXT",$J,LROR)
  1. . . . S LRFLG="F"
  1. . . Q:LRFLG="F"
  1. . . S LRCNT=LRCNT+1,LRCNTT=LRCNTT+1
  1. . . S ^TMP("LRTIUTXT",$J,"TEXT",LRCNT)=LRTXT
  1. . . K ^TMP("LRTIUTXT",$J,LROR)
  1. . I LRFLG="F" D
  1. . . S LRCNT=LRCNT+1,LRCNTT=LRCNTT+1
  1. . . S ^TMP("LRTIUTXT",$J,"FTR",LRCNT)=LRTXT
  1. . . K ^TMP("LRTIUTXT",$J,LROR)
  1. S ^TMP("LRTIUTXT",$J,"FTR")=LRCNT
  1. S ^TMP("LRTIUTXT",$J,0)=LRCNTT
  1. Q
  1. ;
  1. ;
  1. ASKDEV ;
  1. W !
  1. S %ZIS="Q" D ^%ZIS
  1. I POP W ! S LRQUIT=1 Q
  1. I $D(IO("Q")) D
  1. .S ZTDESC="Print Anat Path Reports"
  1. .S ZTRTN="REPORT^LRAPTIUP"
  1. .D ^%ZTLOAD W:$D(ZTSK) !,"Request Queued, #",ZTSK W !
  1. .K ZTSK,IO("Q") D HOME^%ZIS
  1. .S LRQUIT=1
  1. Q
  1. ;
  1. ;
  1. REPORT ;
  1. U IO
  1. W:IOST?1"C-".E @IOF
  1. N LRPG,LRHDC,LRFTC,LRTXC,LRTOTPGS,LROR1,LROR2,LREND
  1. S (LRQUIT,LRPG,LREND)=0
  1. S LRHDC=+$G(^TMP("LRTIUTXT",$J,"HDR"))
  1. S LRFTC=+$G(^TMP("LRTIUTXT",$J,"FTR"))
  1. S LRTXC=+$G(^TMP("LRTIUTXT",$J,"TEXT"))
  1. ;
  1. I (IOSL-LRHDC-LRFTC-4)<1 S LRTOTPGS=LRTXC
  1. E S LRTOTPGS=LRTXC\(IOSL-LRHDC-LRFTC-4) S:LRTXC#(IOSL-LRHDC-LRFTC-4) LRTOTPGS=LRTOTPGS+1
  1. ;
  1. D HEADER
  1. Q:LRQUIT
  1. ;
  1. ; Calculate LR and TIU checksums, if they don't match, set flag to scramble signature on the report.
  1. D CHKSUM
  1. I LRCKSUM'=0,LRCKSUM'=TIUCKSUM S LRENCRYP=1
  1. ;
  1. D BODY
  1. Q:LRQUIT
  1. S LREND=1
  1. D FOOTER
  1. Q
  1. ;
  1. ;
  1. I LRPG>0,IOST?1"C-".E D Q:LRQUIT
  1. . K DIR S DIR(0)="E"
  1. . D ^DIR W !
  1. . S:$D(DTOUT)!(X[U) LRQUIT=1
  1. W:LRPG>0 @IOF S LRPG=LRPG+1
  1. S LROR=0
  1. F S LROR=$O(^TMP("LRTIUTXT",$J,"HDR",LROR)) Q:LROR'>0 D
  1. . S LRTXT=$G(^TMP("LRTIUTXT",$J,"HDR",LROR))
  1. . W LRTXT
  1. . I LRTXT["MEDICAL RECORD"!(LRTXT["AUTOPSY PROTOCOL"),$E(IOST,1,2)'="C-" W ?68,"Pg",$J(LRPG,3)," of ",LRTOTPGS
  1. . W !
  1. Q
  1. ;
  1. ;
  1. BODY ; Body of Report
  1. S LROR1=0
  1. F S LROR1=$O(^TMP("LRTIUTXT",$J,"TEXT",LROR1)) Q:LROR1'>0!(LRQUIT) D
  1. . I $Y>(IOSL-LRFTC-5),$E(IOST,1,2)'="C-" D FOOTER,HEADER Q:LRQUIT
  1. . S LRTXT=$G(^TMP("LRTIUTXT",$J,"TEXT",LROR1))
  1. . I LRTXT["/es/",+$G(LRENCRYP) S LRTXT=$$ENCRYP^XUSRB1(LRTXT)
  1. . W LRTXT,!
  1. Q
  1. ;
  1. ;
  1. S (LROR2,LRCNTF)=0
  1. I IOSL'>66 F Q:$Y>(IOSL-LRFTC-5) W !
  1. F S LROR2=$O(^TMP("LRTIUTXT",$J,"FTR",LROR2)) Q:LROR2'>0 D
  1. . S LRCNTF=LRCNTF+1
  1. . S LRTXT=$G(^TMP("LRTIUTXT",$J,"FTR",LROR2))
  1. . I LRCNTF=2 D Q
  1. . . I LRTXT'=""&(LRTXT'["(End") W LRTXT,! Q
  1. . . I 'LREND W ?57,"(See next page)",! Q
  1. . . W ?57,"(End of report)",!
  1. . W LRTXT,!
  1. Q
  1. ;
  1. ;
  1. CHKSUM ;Compare LR and TIU checksums
  1. ; Get original checksum value from file 63
  1. N LRTREC,LRROOT,LRFILE,LRIENS,LRFLD,LRREL
  1. S (LRENCRYP,LRTREC)=0
  1. I LRSS="AU" D
  1. . S LRTREC=$O(^LR(LRDFN,101,"C",LRPTR,LRTREC))
  1. . S LRIENS=LRDFN_","
  1. . S LRFILE=63.101
  1. I LRSS'="AU" D
  1. . S LRTREC=$O(^LR(LRDFN,LRSS,LRI,.05,"C",LRPTR,LRTREC))
  1. . S LRIENS=LRI_","_LRDFN_","
  1. . S LRFILE=$S(LRSS="SP":63.19,LRSS="CY":63.47,LRSS="EM":63.49,1:"")
  1. I LRFILE=""!(LRTREC=0) S LRCKSUM=0 Q
  1. ; Retrieve LR checksum
  1. S LRIENS=LRTREC_","_LRIENS
  1. S LRCKSUM=$$GET1^DIQ(LRFILE,LRIENS,2)
  1. I LRCKSUM="" S LRCKSUM=0
  1. ;CKA-Calculate checksum of TIU report
  1. S $P(^TMP("LRTIU",$J,LRTIUDA,"TEXT",0),U,5)=$P(^TMP("LRTIU",$J,LRTIUDA,1201,"I"),".")
  1. S LRVAL="^TMP(""LRTIU"","_$J_","_LRTIUDA_",""TEXT"")"
  1. S TIUCKSUM=$$CHKSUM^XUSESIG1(LRVAL)
  1. Q
  1. ;
  1. ;
  1. END ;
  1. W:IOST?1"P-".E @IOF
  1. I LRDEV D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
  1. K ^TMP("LRTIU",$J),^TMP("LRTIUTXT",$J)
  1. K %,DIR,DTOUT,DUOUT,DIRUT,X,Y
  1. K %ZIS,LRCKSUM,LRENCRYP,LRPTR,POP,TIUCKSUM
  1. K ZTDESC,ZTQUEUED,ZTREQ,ZTRTN
  1. Q