LRVRAP4 ;DALOI/STAFF - LAB AP INTERFACE ;06/19/13 11:48
;;5.2;LAB SERVICE;**350,427**;Sep 27, 1994;Build 33
;
; Extracts the results information in the ^LAH(LWL,1,ISQN... global and stores it in the Lab Data AP subfile.
;
DISPLAY ; Display AP results
;
I LRSS'?1(1"SP",1"CY",1"EM") W !,"Abort- Not an AP accession" Q
S %ZIS="MQ" D ^%ZIS
I POP D HOME^%ZIS Q
I $D(IO("Q")) D Q
. S ZTRTN="DQ^LRVRAP4",ZTDESC="PRINT LEDI AP RESULTS",ZTSAVE("LR*")=""
. D ^%ZTLOAD,HOME^%ZIS K IO("Q")
;
;
DQ ;
U IO
N LRLINE,LRI,LRPAGE
S LRPAGE=1,LREND=0,$P(LRLINE,"-",IOM)=""
W @IOF
I $D(LRDFN) D PT^LRX
D HDG,DATA
I $D(ZTQUEUED) S ZTREQ="@" Q
D ACCEPT
;
EXIT ;
Q
;
;
HDG ;
;
W !,"Accession #: ",$G(LRACC)," UID: ",$G(LRUID)
W !,"Name: ",$G(PNM)," SSN: ",$G(SSN)," DOB: ",$$FMTE^XLFDT($G(DOB),"1M")," Age: ",$G(AGE(2))
W ?(IOM-10),"PAGE: ",LRPAGE
W !,"Collection Date: ",$$FMTE^XLFDT($G(LRCDT))
S LRPAGE=LRPAGE+1
W !,LRLINE
Q
;
;
DATA ;
N FLDNM,LINE,LRI
F LRI=99,.2,.3,.4,.5,1,1.1,1.2,1.3,1.4 I $D(^LAH(LRLL,1,LRISQN,LRSS,LRI))&('LREND) D
. S FLDNM=$S(LRI=.2:"Brief Clinical History",LRI=.3:"Preoperative Diagnosis",LRI=.4:"Operative Findings",LRI=.5:"Postoperative Findings",LRI=99:"Report",1:0)
. I FLDNM=0 S FLDNM=$S(LRI=1:"Gross Description",LRI=1.1:"Microscopic Description",LRI=1.2:"Supplementary Report",LRI=1.3:"Frozen Section",1:0)
. I LRI=1.4 S FLDNM=$S(LRSS="EM":"EM",LRSS="SP":"Surgical Pathology",LRSS="CY":"Cytopathology",1:0)_"Diagnosis"
. W !,LRLINE,!,FLDNM
. K ^UTILITY($J)
. S DIWR=IOM-5,DIWL=5,DIWF="W"
. S:LRI=99 DIWR=IOM,DIWL=0
. I LRI=1.2 D PRTSR Q
. S LINE=0
. F S LINE=$O(^LAH(LRLL,1,LRISQN,LRSS,LRI,LINE)) Q:'LINE!LREND D
. . S X=^LAH(LRLL,1,LRISQN,LRSS,LRI,LINE,0) D ^DIWP
. . D ^DIWW
. . D PAUSE Q:LREND
;
Q
;
;
PRTSR ; Print Supplemental Report
N LINE,LRISQN2
S LRISQN2=0
F S LRISQN2=$O(^LAH(LRLL,1,LRISQN,LRSS,LRI,LRISQN2)) Q:'LRISQN2!LREND D
. S LINE=0
. F S LINE=$O(^LAH(LRLL,1,LRISQN,LRSS,LRI,LRISQN2,1,LINE)) Q:'LINE!LREND D
. . S X=^LAH(LRLL,1,LRISQN,LRSS,LRI,LRISQN2,1,LINE,0) D ^DIWP
. . D ^DIWW
. . D PAUSE Q:LREND
Q
;
;
ACCEPT ; Ask if want to accept results
N DIR,DIRUT,DIROUT,DTOUT,DUOUT,X,Y
S DIR(0)="Y",DIR("A")="Do you want to ACCEPT these results",DIR("B")="NO"
S DIR("?")="Enter Y if you want to accept these results"
S DIR("?",1)="Entering Y will store the results for this accession"
D ^DIR
I $D(DIRUT) S LRNOP=1 Q
I 'Y D PURG Q
;
STORE ;
; First, some setup stuff
;
N FIELD,FILE,DIC,LRA,LRI,LRSF,LRP,LRAC
;
S DIC(0)="LXZ"
; Begin actual processing of the data
;
I LRSS="EM" S FILE=63.02
I LRSS="CY" S FILE=63.09
I LRSS="SP" S FILE=63.08
;
; Set DATE REPORT COMPLETED(.03), REPORT RELEASE DATE/TIME (.11) and RELEASED BY (.13) fields
N FDA,FLDS,IEN,LRDATE,LRERR
S LRI=LRIDT,LRDATE=$$NOW^XLFDT,IEN=LRIDT_","_LRDFN_","
S FDA(1,FILE,IEN,.03)=LRDATE
S FDA(1,FILE,IEN,.11)=LRDATE
S FDA(1,FILE,IEN,.13)=DUZ
D FILE^DIE("","FDA(1)","LRERR")
;
F LRI=99,.2,.3,.4,.5,1,1.1,1.2,1.3,1.4 I $D(^LAH(LRLL,1,LRISQN,LRSS,LRI)) D
. S FIELD=$S(LRI=99:99,LRI=.2:.013,LRI=.3:.014,LRI=.4:.015,LRI=.5:.016,LRI=1:1,LRI=1.1:1.1,LRI=1.2:1.2,LRI=1.3:1.3,LRI=1.4:1.4,1:0)
. I LRI=99 D COMMENT Q
. I LRI=1.2 D SRPT Q ; SUPPLEMENTARY REPORT
. D WP^DIE(FILE,LRIDT_","_LRDFN_",",FIELD,"K","^LAH(LRLL,1,LRISQN,LRSS,LRI)","LRERR") ; WORD-PROCESSING FIELDS
;
; Store performing lab info
I $D(^TMP("LRPL",$J)) D ROLLUPPL^LRRPLUA(LRDFN,LRSS,LRIDT)
;
; Ask for performing laboratory assignment
W !! D EDIT^LRRPLU(LRDFN,LRSS,LRIDT)
;
; Store reporting lab
D SETRL^LRVERA(LRDFN,LRSS,LRIDT,DUZ(2))
S LRI=LRIDT,LRSF=FILE,LRP=PNM,LRAC=LRACC
S LRA=^LR(LRDFN,LRSS,LRIDT,0)
D ACCCOMP^LRAPRES
D MAIN^LRAPRES1(LRDFN,LRSS,LRI,LRSF,LRP,LRAC)
;
; Update clinical reminders
D UPDATE^LRPXRM(LRDFN,LRSS,LRIDT)
;
; Queue results if LEDI and cleanup
D LEDI^LRVR0,ZAP^LRVR0
;
;K ENTRY,I,SECTION,FDA,FILE,DIC,Y,BUG,IEN,M,F
Q
;
;
N CFILE,LRISQN2
S LRISQN2=0
I LRSS="SP" S CFILE=63.98
I LRSS="CY" S CFILE=63.908
I LRSS="EM" S CFILE=63.208
F S LRISQN2=$O(^LAH(LRLL,1,LRISQN,LRSS,LRI,LRISQN2)) Q:'LRISQN2 S LRLINE=^LAH(LRLL,1,LRISQN,LRSS,LRI,LRISQN2,0) D
. K FDA,IEN,LRERR
. S IEN="?+1,"_LRIDT_","_LRDFN_","
. S FDA(2,CFILE,IEN,.01)=LRLINE
. D UPDATE^DIE("","FDA(2)","IEN","LRERR")
Q
;
;
SRPT ; SUPPLEMENTARY REPORT
N SRFILE,LRISQN2
S LRISQN2=0
I LRSS="SP" S SRFILE=63.817,FIELD=1
I LRSS="CY" S SRFILE=63.907,FIELD=1
I LRSS="EM" S SRFILE=63.207,FIELD=1
F S LRISQN2=$O(^LAH(LRLL,1,LRISQN,LRSS,LRI,LRISQN2)) Q:'LRISQN2 D
. K FDA,IEN,LRERR,LRERR2
. S IEN="?+1,"_LRIDT_","_LRDFN_","
. S FDA(1,SRFILE,IEN,.01)=$$NOW^XLFDT
. S FDA(1,SRFILE,IEN,.02)=1
. D UPDATE^DIE("","FDA(1)","IEN","LRERR2")
. I $G(IEN(1)) D WP^DIE(SRFILE,IEN(1)_","_LRIDT_","_LRDFN_",",FIELD,"K","^LAH(LRLL,1,LRISQN,LRSS,LRI,LRISQN2,1)","LRERR")
Q
;
;
PURG ; Ask if the entry should be purged from ^LAH(
W !
N DIR,DIRUT,DIROUT,DTOUT,DUOUT,X,Y
S DIR(0)="Y",DIR("A")="Do you want to purge this entry from ^LAH Global"
S DIR("?")="Remove the entry from the list",DIR("B")="No"
D ^DIR
I $D(DIRUT) S LRNOP=1 Q
I $G(Y)=1 D ZAP^LRVR0
Q
;
;
PAUSE ; Check for end of page
I $Y>(IOSL-6)&($E(IOST,1,2)="C-") D Q:$G(LREND)
. N DIR,DIRUT,DIROUT,DTOUT,DUOUT,X,Y
. S DIR(0)="E"
. D ^DIR S:'Y LREND=1
I $Y>(IOSL-6) S $Y=0 W @IOF D HDG Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRVRAP4 5517 printed Sep 23, 2025@19:58:23 Page 2
LRVRAP4 ;DALOI/STAFF - LAB AP INTERFACE ;06/19/13 11:48
+1 ;;5.2;LAB SERVICE;**350,427**;Sep 27, 1994;Build 33
+2 ;
+3 ; Extracts the results information in the ^LAH(LWL,1,ISQN... global and stores it in the Lab Data AP subfile.
+4 ;
DISPLAY ; Display AP results
+1 ;
+2 IF LRSS'?1(1"SP",1"CY",1"EM")
WRITE !,"Abort- Not an AP accession"
QUIT
+3 SET %ZIS="MQ"
DO ^%ZIS
+4 IF POP
DO HOME^%ZIS
QUIT
+5 IF $DATA(IO("Q"))
Begin DoDot:1
+6 SET ZTRTN="DQ^LRVRAP4"
SET ZTDESC="PRINT LEDI AP RESULTS"
SET ZTSAVE("LR*")=""
+7 DO ^%ZTLOAD
DO HOME^%ZIS
KILL IO("Q")
End DoDot:1
QUIT
+8 ;
+9 ;
DQ ;
+1 USE IO
+2 NEW LRLINE,LRI,LRPAGE
+3 SET LRPAGE=1
SET LREND=0
SET $PIECE(LRLINE,"-",IOM)=""
+4 WRITE @IOF
+5 IF $DATA(LRDFN)
DO PT^LRX
+6 DO HDG
DO DATA
+7 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+8 DO ACCEPT
+9 ;
EXIT ;
+1 QUIT
+2 ;
+3 ;
HDG ;
+1 ;
+2 WRITE !,"Accession #: ",$GET(LRACC)," UID: ",$GET(LRUID)
+3 WRITE !,"Name: ",$GET(PNM)," SSN: ",$GET(SSN)," DOB: ",$$FMTE^XLFDT($GET(DOB),"1M")," Age: ",$GET(AGE(2))
+4 WRITE ?(IOM-10),"PAGE: ",LRPAGE
+5 WRITE !,"Collection Date: ",$$FMTE^XLFDT($GET(LRCDT))
+6 SET LRPAGE=LRPAGE+1
+7 WRITE !,LRLINE
+8 QUIT
+9 ;
+10 ;
DATA ;
+1 NEW FLDNM,LINE,LRI
+2 FOR LRI=99,.2,.3,.4,.5,1,1.1,1.2,1.3,1.4
IF $DATA(^LAH(LRLL,1,LRISQN,LRSS,LRI))&('LREND)
Begin DoDot:1
+3 SET FLDNM=$SELECT(LRI=.2:"Brief Clinical History",LRI=.3:"Preoperative Diagnosis",LRI=.4:"Operative Findings",LRI=.5:"Postoperative Findings",LRI=99:"Report",1:0)
+4 IF FLDNM=0
SET FLDNM=$SELECT(LRI=1:"Gross Description",LRI=1.1:"Microscopic Description",LRI=1.2:"Supplementary Report",LRI=1.3:"Frozen Section",1:0)
+5 IF LRI=1.4
SET FLDNM=$SELECT(LRSS="EM":"EM",LRSS="SP":"Surgical Pathology",LRSS="CY":"Cytopathology",1:0)_"Diagnosis"
+6 WRITE !,LRLINE,!,FLDNM
+7 KILL ^UTILITY($JOB)
+8 SET DIWR=IOM-5
SET DIWL=5
SET DIWF="W"
+9 if LRI=99
SET DIWR=IOM
SET DIWL=0
+10 IF LRI=1.2
DO PRTSR
QUIT
+11 SET LINE=0
+12 FOR
SET LINE=$ORDER(^LAH(LRLL,1,LRISQN,LRSS,LRI,LINE))
if 'LINE!LREND
QUIT
Begin DoDot:2
+13 SET X=^LAH(LRLL,1,LRISQN,LRSS,LRI,LINE,0)
DO ^DIWP
+14 DO ^DIWW
+15 DO PAUSE
if LREND
QUIT
End DoDot:2
End DoDot:1
+16 ;
+17 QUIT
+18 ;
+19 ;
PRTSR ; Print Supplemental Report
+1 NEW LINE,LRISQN2
+2 SET LRISQN2=0
+3 FOR
SET LRISQN2=$ORDER(^LAH(LRLL,1,LRISQN,LRSS,LRI,LRISQN2))
if 'LRISQN2!LREND
QUIT
Begin DoDot:1
+4 SET LINE=0
+5 FOR
SET LINE=$ORDER(^LAH(LRLL,1,LRISQN,LRSS,LRI,LRISQN2,1,LINE))
if 'LINE!LREND
QUIT
Begin DoDot:2
+6 SET X=^LAH(LRLL,1,LRISQN,LRSS,LRI,LRISQN2,1,LINE,0)
DO ^DIWP
+7 DO ^DIWW
+8 DO PAUSE
if LREND
QUIT
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
+11 ;
ACCEPT ; Ask if want to accept results
+1 NEW DIR,DIRUT,DIROUT,DTOUT,DUOUT,X,Y
+2 SET DIR(0)="Y"
SET DIR("A")="Do you want to ACCEPT these results"
SET DIR("B")="NO"
+3 SET DIR("?")="Enter Y if you want to accept these results"
+4 SET DIR("?",1)="Entering Y will store the results for this accession"
+5 DO ^DIR
+6 IF $DATA(DIRUT)
SET LRNOP=1
QUIT
+7 IF 'Y
DO PURG
QUIT
+8 ;
STORE ;
+1 ; First, some setup stuff
+2 ;
+3 NEW FIELD,FILE,DIC,LRA,LRI,LRSF,LRP,LRAC
+4 ;
+5 SET DIC(0)="LXZ"
+6 ; Begin actual processing of the data
+7 ;
+8 IF LRSS="EM"
SET FILE=63.02
+9 IF LRSS="CY"
SET FILE=63.09
+10 IF LRSS="SP"
SET FILE=63.08
+11 ;
+12 ; Set DATE REPORT COMPLETED(.03), REPORT RELEASE DATE/TIME (.11) and RELEASED BY (.13) fields
+13 NEW FDA,FLDS,IEN,LRDATE,LRERR
+14 SET LRI=LRIDT
SET LRDATE=$$NOW^XLFDT
SET IEN=LRIDT_","_LRDFN_","
+15 SET FDA(1,FILE,IEN,.03)=LRDATE
+16 SET FDA(1,FILE,IEN,.11)=LRDATE
+17 SET FDA(1,FILE,IEN,.13)=DUZ
+18 DO FILE^DIE("","FDA(1)","LRERR")
+19 ;
+20 FOR LRI=99,.2,.3,.4,.5,1,1.1,1.2,1.3,1.4
IF $DATA(^LAH(LRLL,1,LRISQN,LRSS,LRI))
Begin DoDot:1
+21 SET FIELD=$SELECT(LRI=99:99,LRI=.2:.013,LRI=.3:.014,LRI=.4:.015,LRI=.5:.016,LRI=1:1,LRI=1.1:1.1,LRI=1.2:1.2,LRI=1.3:1.3,LRI=1.4:1.4,1:0)
+22 IF LRI=99
DO COMMENT
QUIT
+23 ; SUPPLEMENTARY REPORT
IF LRI=1.2
DO SRPT
QUIT
+24 ; WORD-PROCESSING FIELDS
DO WP^DIE(FILE,LRIDT_","_LRDFN_",",FIELD,"K","^LAH(LRLL,1,LRISQN,LRSS,LRI)","LRERR")
End DoDot:1
+25 ;
+26 ; Store performing lab info
+27 IF $DATA(^TMP("LRPL",$JOB))
DO ROLLUPPL^LRRPLUA(LRDFN,LRSS,LRIDT)
+28 ;
+29 ; Ask for performing laboratory assignment
+30 WRITE !!
DO EDIT^LRRPLU(LRDFN,LRSS,LRIDT)
+31 ;
+32 ; Store reporting lab
+33 DO SETRL^LRVERA(LRDFN,LRSS,LRIDT,DUZ(2))
+34 SET LRI=LRIDT
SET LRSF=FILE
SET LRP=PNM
SET LRAC=LRACC
+35 SET LRA=^LR(LRDFN,LRSS,LRIDT,0)
+36 DO ACCCOMP^LRAPRES
+37 DO MAIN^LRAPRES1(LRDFN,LRSS,LRI,LRSF,LRP,LRAC)
+38 ;
+39 ; Update clinical reminders
+40 DO UPDATE^LRPXRM(LRDFN,LRSS,LRIDT)
+41 ;
+42 ; Queue results if LEDI and cleanup
+43 DO LEDI^LRVR0
DO ZAP^LRVR0
+44 ;
+45 ;K ENTRY,I,SECTION,FDA,FILE,DIC,Y,BUG,IEN,M,F
+46 QUIT
+47 ;
+48 ;
+1 NEW CFILE,LRISQN2
+2 SET LRISQN2=0
+3 IF LRSS="SP"
SET CFILE=63.98
+4 IF LRSS="CY"
SET CFILE=63.908
+5 IF LRSS="EM"
SET CFILE=63.208
+6 FOR
SET LRISQN2=$ORDER(^LAH(LRLL,1,LRISQN,LRSS,LRI,LRISQN2))
if 'LRISQN2
QUIT
SET LRLINE=^LAH(LRLL,1,LRISQN,LRSS,LRI,LRISQN2,0)
Begin DoDot:1
+7 KILL FDA,IEN,LRERR
+8 SET IEN="?+1,"_LRIDT_","_LRDFN_","
+9 SET FDA(2,CFILE,IEN,.01)=LRLINE
+10 DO UPDATE^DIE("","FDA(2)","IEN","LRERR")
End DoDot:1
+11 QUIT
+12 ;
+13 ;
SRPT ; SUPPLEMENTARY REPORT
+1 NEW SRFILE,LRISQN2
+2 SET LRISQN2=0
+3 IF LRSS="SP"
SET SRFILE=63.817
SET FIELD=1
+4 IF LRSS="CY"
SET SRFILE=63.907
SET FIELD=1
+5 IF LRSS="EM"
SET SRFILE=63.207
SET FIELD=1
+6 FOR
SET LRISQN2=$ORDER(^LAH(LRLL,1,LRISQN,LRSS,LRI,LRISQN2))
if 'LRISQN2
QUIT
Begin DoDot:1
+7 KILL FDA,IEN,LRERR,LRERR2
+8 SET IEN="?+1,"_LRIDT_","_LRDFN_","
+9 SET FDA(1,SRFILE,IEN,.01)=$$NOW^XLFDT
+10 SET FDA(1,SRFILE,IEN,.02)=1
+11 DO UPDATE^DIE("","FDA(1)","IEN","LRERR2")
+12 IF $GET(IEN(1))
DO WP^DIE(SRFILE,IEN(1)_","_LRIDT_","_LRDFN_",",FIELD,"K","^LAH(LRLL,1,LRISQN,LRSS,LRI,LRISQN2,1)","LRERR")
End DoDot:1
+13 QUIT
+14 ;
+15 ;
PURG ; Ask if the entry should be purged from ^LAH(
+1 WRITE !
+2 NEW DIR,DIRUT,DIROUT,DTOUT,DUOUT,X,Y
+3 SET DIR(0)="Y"
SET DIR("A")="Do you want to purge this entry from ^LAH Global"
+4 SET DIR("?")="Remove the entry from the list"
SET DIR("B")="No"
+5 DO ^DIR
+6 IF $DATA(DIRUT)
SET LRNOP=1
QUIT
+7 IF $GET(Y)=1
DO ZAP^LRVR0
+8 QUIT
+9 ;
+10 ;
PAUSE ; Check for end of page
+1 IF $Y>(IOSL-6)&($EXTRACT(IOST,1,2)="C-")
Begin DoDot:1
+2 NEW DIR,DIRUT,DIROUT,DTOUT,DUOUT,X,Y
+3 SET DIR(0)="E"
+4 DO ^DIR
if 'Y
SET LREND=1
End DoDot:1
if $GET(LREND)
QUIT
+5 IF $Y>(IOSL-6)
SET $Y=0
WRITE @IOF
DO HDG
QUIT
+6 QUIT
