Routine: LRVRAP4

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 ;

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

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

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

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

COMMENT ;

 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")

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")

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

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRVRAP4   5517     printed  Mar 13, 2025@21:27:13                                                                                                                                                                                                     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      ;

COMMENT   ;

 +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

LRVRAP4.m