Context Navigation

← Previous Change
Next Change →

LAB_SERVICE-LR-LS

Timestamp:

Dec 4, 2009, 12:11:15 AM (15 years ago)

Author:

George Lilly

Message:

revised back to 6/30/08 version

Location:

WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS

Files:

: 15 edited

LR7OB69.m (modified) (1 diff)
LR7OGG.m (modified) (1 diff)
LR7OGMG.m (modified) (1 diff)
LR7OGMM.m (modified) (1 diff)
LR7OSAP2.m (modified) (1 diff)
LRAPBR1.m (modified) (1 diff)
LRAPDA.m (modified) (1 diff)
LRAPR.m (modified) (1 diff)
LRAPRES1.m (modified) (1 diff)
LRSPT.m (modified) (1 diff)
LRSRVR6.m (modified) (1 diff)
LRVER3A.m (modified) (1 diff)
LRWLST1.m (modified) (1 diff)
LRWLST11.m (modified) (1 diff)
LRWOMEN.m (modified) (1 diff)

Legend:

: Unmodified
: Added
: Removed

WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LR7OB69.m

-              r613
+              r623
+LR7OB69 ;slc/dcm/JAH - Get Lab order data from 69 - 68 - 63 ;8/10/04
+        ;;5.2;LAB SERVICE;**121,187,224,291,373**;Sep 27, 1994;Build 1
+        ;
+(ODT,SN)      ;Get data from file 69
+        ;ODT=Order Date subscript in file 69
+        ;SN=Specimen number subscript in file 69
+        ;Y1=Lab order number
+        ;Y2=Start date
+        ;Y3=Sample
+        ;Y4=Collection type/Specimen Action code
+        ;Y5=Order date
+        ;Y6=Provider
+        ;Y7=Routing Location
+        ;Y8=Lab arrival time
+        ;Y9=Date/Time Results Available
+        ;Y10=Specimen
+        ;Y11=OERR Order #
+        ;Y12=Entering person
+        ;^TMP("LRX",$J,69)=Y1^Y2^Y3^Y4^Y5^Y6^Y7^Y8^Y9^Y10^Y11^Y12
+        ;^TMP("LRX",$J,69,i)=Test^Urgency^Accession Date^Accession area^Accession #^Combined on order^ORIFN^Panel exploded
+        ;^TMP("LRX",$J,69,"N",i)=Specimen level comments (6 node)
+        ;^TMP("LRX",$J,69,i,"N",ifn)=Comments by test
+        ;^TMP("LRX",$J,69,i,"NC",ifn)=Free text cancel reason
+        ;^TMP("LRX",$J,69,i,"DGX",ifn)=diagnosis^SC^CV^AO^IR^EC^HNC^MST
+        ;^TMP("LRX",$J,69,i,63,ifn)=
+        ;Test subscript^Result^Flag^Units^Ref Range^Result status^Observation Sub ID^Value type^Natl Procedure code^Natl Procedure Name^Natl Coding System^Verified by^^Theraputic flag (T or "")^Print name^Accession^Order #^Link to 63
+        ;^TMP("LRX",$J,69,i,63,"N",ifn)=Result Comments
+        ;^TMP("LRX",$J,69,i,68)=Lab Order #^LRDFN^Accession^Draw Time^Lab Arrival time^DT Results Available^Inverse Date
+        ;^TMP("LRX",$J,69,i,68,ifn)=Test^Urgency^Technologist^Complete Date
+        ;^TMP("LRX",$J,69,"N",i)= Ward comments on specimen
+        N X,X0,XP1,X1,X4,Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8,Y9,Y10,Y11,Y12,IFN,TSTY,NOTE,GOTCOM K ^TMP("LRX",$J,69)
+        Q:'$D(^LRO(69,+ODT,1,+SN,0))  S X0=^(0),XP1=$G(^(.1)),X1=$G(^(1)),X3=$G(^(3)),X4=$O(^(4,0))
+        Q:'$D(^LR(+X0,0))  ;No matching entry in ^LR
+        S:'$D(DFN) DFN=$P(^LR(+X0,0),"^",3) S:'$D(LRDFN) LRDFN=+X0 S:'$D(LRDPF) LRDPF=$P(^LR(+X0,0),"^",2)_$G(^DIC(+$P(^LR(+X0,0),"^",2),0,"GL"))
+        S Y1=+XP1,Y2=$S($P(X1,"^"):$P(X1,"^"),1:$P(X0,"^",8)),Y3=$P(X0,"^",3),Y4=$P(X0,"^",4),Y5=$P(X0,"^",5),Y6=$P(X0,"^",6),Y7=$P(X0,"^",9),Y8=$P(X3,"^"),Y9=$P(X3,"^",2),Y11=$P(X0,"^",11),Y12=$P(X0,"^",2)
+        ;canceled entries are skipped, so calls to this routine from options
+        ;that are removing tests need to make the call before setting the pieces
+        ;that cancel the test: $P(^LRO(69,ODT,1,SN,2,IFN,0),"^",11)
+        ;See DOUT^LRTSTJAN
+        S IFN=0 F  S IFN=$O(^LRO(69,ODT,1,SN,2,IFN)) Q:IFN<1  S X=$G(^(IFN,0)) I X,'$P(X,"^",11) D
+        . I $G(LRNIFN),$D(LRTMPO("LRIFN",LRNIFN)) Q:+X'=+LRTMPO("LRIFN",LRNIFN)
+        . S ^TMP("LRX",$J,69,IFN)=X,I=0
+        . D GDG1^LRBEBA2(ODT,SN,IFN)
+        . F  S I=$O(^LRO(69,ODT,1,SN,2,IFN,1,I)) Q:I<1  S X=^(I,0) D
+        .. S ^TMP("LRX",$J,69,IFN,"N",I)=X
+        . S I=0 F  S I=$O(^LRO(69,ODT,1,SN,2,IFN,1.1,I)) Q:I<1  S X=^(I,0) D
+        .. S ^TMP("LRX",$J,69,IFN,"NC",I)=X
+        S IFN=0 F  S IFN=$O(^LRO(69,ODT,1,SN,6,IFN)) Q:IFN<1  S X=^(IFN,0) D
+        . Q:X["removed ==>"  Q:X["deleted by"
+        . S ^TMP("LRX",$J,69,"N",IFN)=X
+        S Y10=$O(^LRO(69,ODT,1,SN,4,0)),Y10=$S(Y10:$P(^(Y10,0),"^"),1:"")
+        S ^TMP("LRX",$J,69)=Y1_"^"_Y2_"^"_Y3_"^"_Y4_"^"_Y5_"^"_Y6_"^"_Y7_"^"_Y8_"^"_Y9_"^"_Y10_"^"_Y11_"^"_Y12
+        S IFN=0 F  S IFN=$O(^TMP("LRX",$J,69,IFN)) Q:IFN<1  S X=^TMP("LRX",$J,69,IFN) S X1=$P(X,"^",3),X2=$P(X,"^",4),X3=$P(X,"^",5) K TSTY D EN^LR7OU1(+X,$P(^LAB(60,+X,0),"^",5)) D 68^LR7OB68(IFN,X1,X2,X3,+X)
+        Q
+LR7OB69 ;slc/dcm/JAH - Get Lab order data from 69 - 68 - 63 ;8/10/04
+ ;;5.2;LAB SERVICE;**121,187,224,291**;Sep 27, 1994
+ ;
+(ODT,SN) ;Get data from file 69
+ ;ODT=Order Date subscript in file 69
+ ;SN=Specimen number subscript in file 69
+ ;Y1=Lab order number
+ ;Y2=Start date
+ ;Y3=Sample
+ ;Y4=Collection type/Specimen Action code
+ ;Y5=Order date
+ ;Y6=Provider
+ ;Y7=Routing Location
+ ;Y8=Lab arrival time
+ ;Y9=Date/Time Results Available
+ ;Y10=Specimen
+ ;Y11=OERR Order #
+ ;Y12=Entering person
+ ;^TMP("LRX",$J,69)=Y1^Y2^Y3^Y4^Y5^Y6^Y7^Y8^Y9^Y10^Y11^Y12
+ ;^TMP("LRX",$J,69,i)=Test^Urgency^Accession Date^Accession area^Accession #^Combined on order^ORIFN^Panel exploded
+ ;^TMP("LRX",$J,69,"N",i)=Specimen level comments (6 node)
+ ;^TMP("LRX",$J,69,i,"N",ifn)=Comments by test
+ ;^TMP("LRX",$J,69,i,"NC",ifn)=Free text cancel reason
+ ;^TMP("LRX",$J,69,i,"DGX",ifn)=diagnosis^SC^CV^AO^IR^EC^HNC^MST
+ ;^TMP("LRX",$J,69,i,63,ifn)=
+ ;Test subscript^Result^Flag^Units^Ref Range^Result status^Observation Sub ID^Value type^Natl Procedure code^Natl Procedure Name^Natl Coding System^Verified by^^Theraputic flag (T or "")^Print name^Accession^Order #^Link to 63
+ ;^TMP("LRX",$J,69,i,63,"N",ifn)=Result Comments
+ ;^TMP("LRX",$J,69,i,68)=Lab Order #^LRDFN^Accession^Draw Time^Lab Arrival time^DT Results Available^Inverse Date
+ ;^TMP("LRX",$J,69,i,68,ifn)=Test^Urgency^Technologist^Complete Date
+ ;^TMP("LRX",$J,69,"N",i)= Ward comments on specimen
+ N X,X0,XP1,X1,X4,Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8,Y9,Y10,Y11,Y12,IFN,TSTY,NOTE,GOTCOM K ^TMP("LRX",$J,69)
+ Q:'$D(^LRO(69,+ODT,1,+SN,0))  S X0=^(0),XP1=$G(^(.1)),X1=$G(^(1)),X3=$G(^(3)),X4=$O(^(4,0))
+ Q:'$D(^LR(+X0,0))  ;No matching entry in ^LR
+ S:'$D(DFN) DFN=$P(^LR(+X0,0),"^",3) S:'$D(LRDFN) LRDFN=+X0 S:'$D(LRDPF) LRDPF=$P(^LR(+X0,0),"^",2)_$G(^DIC(+$P(^LR(+X0,0),"^",2),0,"GL"))
+ S Y1=+XP1,Y2=$S($P(X1,"^"):$P(X1,"^"),1:$P(X0,"^",8)),Y3=$P(X0,"^",3),Y4=$P(X0,"^",4),Y5=$P(X0,"^",5),Y6=$P(X0,"^",6),Y7=$P(X0,"^",7),Y8=$P(X3,"^"),Y9=$P(X3,"^",2),Y11=$P(X0,"^",11),Y12=$P(X0,"^",2)
+ S:$L(Y7) Y7=$O(^SC("C",Y7,0))
+ ;canceled entries are skipped, so calls to this routine from options
+ ;that are removing tests need to make the call before setting the pieces
+ ;that cancel the test: $P(^LRO(69,ODT,1,SN,2,IFN,0),"^",11)
+ ;See DOUT^LRTSTJAN
+ S IFN=0 F  S IFN=$O(^LRO(69,ODT,1,SN,2,IFN)) Q:IFN<1  S X=$G(^(IFN,0)) I X,'$P(X,"^",11) D
+ . I $G(LRNIFN),$D(LRTMPO("LRIFN",LRNIFN)) Q:+X'=+LRTMPO("LRIFN",LRNIFN)
+ . S ^TMP("LRX",$J,69,IFN)=X,I=0
+ . D GDG1^LRBEBA2(ODT,SN,IFN)
+ . F  S I=$O(^LRO(69,ODT,1,SN,2,IFN,1,I)) Q:I<1  S X=^(I,0) D
+ .. S ^TMP("LRX",$J,69,IFN,"N",I)=X
+ . S I=0 F  S I=$O(^LRO(69,ODT,1,SN,2,IFN,1.1,I)) Q:I<1  S X=^(I,0) D
+ .. S ^TMP("LRX",$J,69,IFN,"NC",I)=X
+ S IFN=0 F  S IFN=$O(^LRO(69,ODT,1,SN,6,IFN)) Q:IFN<1  S X=^(IFN,0) D
+ . Q:X["removed ==>"  Q:X["deleted by"
+ . S ^TMP("LRX",$J,69,"N",IFN)=X
+ S Y10=$O(^LRO(69,ODT,1,SN,4,0)),Y10=$S(Y10:$P(^(Y10,0),"^"),1:"")
+ S ^TMP("LRX",$J,69)=Y1_"^"_Y2_"^"_Y3_"^"_Y4_"^"_Y5_"^"_Y6_"^"_Y7_"^"_Y8_"^"_Y9_"^"_Y10_"^"_Y11_"^"_Y12
+ S IFN=0 F  S IFN=$O(^TMP("LRX",$J,69,IFN)) Q:IFN<1  S X=^TMP("LRX",$J,69,IFN) S X1=$P(X,"^",3),X2=$P(X,"^",4),X3=$P(X,"^",5) K TSTY D EN^LR7OU1(+X,$P(^LAB(60,+X,0),"^",5)) D 68^LR7OB68(IFN,X1,X2,X3,+X)
+ Q

WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LR7OGG.m

-              r613
+              r623
+LR7OGG  ;DALOI/STAFF- Interim report rpc grid ; Feb 9, 2005
+        ;;5.2;LAB SERVICE;**187,290,364**;Sep 27, 1994;Build 3
+        ;
+TEST    ; test use only
+        N CNT,I K ^TMP("LR7OGX",$J)
+        S ^TMP("LR7OGX",$J,"INPUT",1)="2^2970202^2920202"
+        S CNT=1
+        ;F I=1:1:10 I $D(^LAB(60,I,0)) S CNT=CNT+1,^TMP("LR7OGX",$J,"INPUT",CNT)=I
+        F I=7,173,9,1 I $D(^LAB(60,I,0)) S CNT=CNT+1,^TMP("LR7OGX",$J,"INPUT",CNT)=I
+        D GRIDDATA
+        S I=0 F  S I=$O(^TMP("LR7OGX",$J,"OUTPUT",I)) Q:I<1  W !,^(I)
+        K ^TMP("LR7OGX",$J)
+        Q
+        ;
+GRID(ROOT,DFN,DATE1,DATE2,SPEC,TESTS)   ; from ORWLRR
+        N CNT,NUM
+        K ^TMP("LR7OGX",$J,"INPUT"),^("OUTPUT")
+        S ROOT=$NA(^TMP("LR7OGX",$J,"OUTPUT"))
+        S ^TMP("LR7OGX",$J,"INPUT",1)=DFN_U_DATE1_U_DATE2_U_+SPEC
+        S CNT=1,NUM=0 F  S NUM=$O(TESTS(NUM)) Q:NUM<1  D
+        .S CNT=CNT+1
+        .S ^TMP("LR7OGX",$J,"INPUT",CNT)=+TESTS(NUM)
+        D GRIDDATA
+        Q
+        ;
+GRIDDATA        ;
+        ; input format
+        ; ^TMP("LR7OGX",$J,"INPUT",1)=dfn^start date^end date^spec^all tests
+        ; ^TMP("LR7OGX",$J,"INPUT",#)=test#  (tests displayed in this order)
+        ;   (these tests should, be atomic, subscript - ch, type - both or output)
+        ;
+        S ^TMP("LR7OGX",$J,"OUTPUT",1)="0^0^0^1"
+        N ABCNT,ABDCNT,ABLINE,ABTCNT,ABTLINE,ADCNT,ADSEQ,AGE,ATCNT,ATSEQ,CDT,CHSUB,COMCNT,COMMENT,DATACNT,DATESEQ,DFN,EDATE,EDT,FLAG,IDT
+        N LINE,LRCW,LRDFN,LRX,NUM,ONLYSPEC,OUTCNT,PNM,PRNTCODE,RESULT,SDATE,SEX,SPEC,SPECNAME,TESTNAME,TESTNUM,TESTSEQ,TESTZERO,X,ZERO,INEXACT,DISPDATE
+        K ^TMP("LR7OG",$J)
+        S DFN=+^TMP("LR7OGX",$J,"INPUT",1),SDATE=+$P(^(1),U,2),EDATE=+$P(^(1),U,3),ONLYSPEC=+$P(^(1),U,4)
+        D DEMO^LR7OGU(DFN,.LRDFN,.PNM,.AGE,.SEX)
+        Q:'DFN  Q:'SDATE  Q:'EDATE  Q:'LRDFN
+        S OUTCNT=1,(ADCNT,ADSEQ,ATCNT,ATSEQ,COMCNT,DATACNT,DATESEQ,TESTSEQ,TCNT)=0
+        S NUM=1
+        F  S NUM=$O(^TMP("LR7OGX",$J,"INPUT",NUM)) Q:NUM<1  S TESTNUM=+^(NUM) D
+        . S TESTZERO=$G(^LAB(60,TESTNUM,0))
+        . S CHSUB=$P($P(TESTZERO,U,5),";",2)
+        . I 'CHSUB Q
+        . S TESTNAME=$P($G(^LAB(60,TESTNUM,.1)),U),PRNTCODE=$P($G(^(.1)),U,3)
+        . I TESTNAME="" S TESTNAME=$P(TESTZERO,U)
+        . S TESTSEQ=TESTSEQ+1
+        . S LINE=TESTSEQ_U_TESTNUM_U_TESTNAME_U_PRNTCODE
+        . S ^TMP("LR7OG",$J,"TEST",CHSUB)=LINE
+        . S OUTCNT=OUTCNT+1
+        . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=LINE
+        S ^TMP("LR7OGX",$J,"OUTPUT",1)=TESTSEQ
+        S EDATE=EDATE\1
+        S IDT=9999999-SDATE,EDT=9999999-EDATE
+        F  S IDT=$O(^LR(LRDFN,"CH",IDT)) Q:IDT<1  Q:IDT>EDT  D
+        . S ZERO=^LR(LRDFN,"CH",IDT,0)
+        . I '$P(ZERO,U,3) Q
+        . S CDT=+ZERO,INEXACT=$P(ZERO,U,2),SPEC=+$P(ZERO,U,5),SPECNAME=$P($G(^LAB(61,SPEC,0)),U),COMMENT=$S($O(^LR(LRDFN,"CH",IDT,1,0)):"**",1:"")
+        . I ONLYSPEC,SPEC'=ONLYSPEC Q
+        . S CHSUB=1
+        . F  S CHSUB=$O(^LR(LRDFN,"CH",IDT,CHSUB)) Q:CHSUB=""  D
+        . . I '$D(^TMP("LR7OG",$J,"TEST",CHSUB)) Q
+        . . I '$D(^TMP("LR7OG",$J,"DATE",IDT)) S ^(IDT)="" D
+        . . . S DATESEQ=DATESEQ+1
+        . . . S OUTCNT=OUTCNT+1
+        . . . S DISPDATE=$S(INEXACT:CDT\1,1:CDT)
+        . . . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=DATESEQ_U_CDT_U_SPEC_U_SPECNAME_U_COMMENT_U_DISPDATE
+        . . . I COMMENT'="" D
+        . . . . S COMCNT=COMCNT+1
+        . . . . S ^TMP("LR7OG",$J,"COMMENT",COMCNT)=$P($$FMTE^XLFDT(CDT),":",1,2)_" ** Comments:"
+        . . . . S NUM=0
+        . . . . F  S NUM=$O(^LR(LRDFN,"CH",IDT,1,NUM)) Q:NUM<1  S LINE=$G(^(NUM,0)) D
+        . . . . . S COMCNT=COMCNT+1
+        . . . . . S ^TMP("LR7OG",$J,"COMMENT",COMCNT)=LINE
+        . . . . S COMCNT=COMCNT+1
+        . . . . S ^TMP("LR7OG",$J,"COMMENT",COMCNT)=""
+        . . S LRX=$$TSTRES^LRRPU(LRDFN,"CH",IDT,CHSUB,"")
+        . . S RESULT=$P(LRX,"^"),FLAG=$P(LRX,U,2)
+        . . S PRNTCODE=$P(^TMP("LR7OG",$J,"TEST",CHSUB),U,4)
+        . . I PRNTCODE'="" S X=RESULT,LRCW=8 S @("RESULT="_PRNTCODE)
+        . . E  S RESULT=$J(RESULT,8)
+        . . S RESULT=$$STRIP^LR7OGU(RESULT)
+        . . I FLAG'="" D
+        . . . S ABTLINE=^TMP("LR7OG",$J,"TEST",CHSUB)
+        . . . I '$D(^TMP("LR7OG",$J,"ABTSEQ",+ABTLINE)) S ^(+ABTLINE)=U_$P(ABTLINE,U,2,3)
+        . . . I '$D(^TMP("LR7OG",$J,"ABDSEQ",IDT)) S ^(IDT)=U_CDT_U_SPEC_U_SPECNAME_U_COMMENT
+        . . . S ^TMP("LR7OG",$J,"ABDATA",IDT,+ABTLINE)=RESULT_U_FLAG
+        . . S TESTSEQ=+^TMP("LR7OG",$J,"TEST",CHSUB)
+        . . S DATACNT=DATACNT+1
+        . . S ^TMP("LR7OG",$J,"DATA",DATACNT)=DATESEQ_U_TESTSEQ_U_RESULT_U_FLAG
+        . . D TESTSPEC(CHSUB,SPEC,SPECNAME,AGE,SEX)
+        S $P(^TMP("LR7OGX",$J,"OUTPUT",1),U,2,3)=DATESEQ_U_DATACNT
+        S DATACNT=0
+        F  S DATACNT=$O(^TMP("LR7OG",$J,"DATA",DATACNT)) Q:DATACNT<1  S LINE=^(DATACNT) D
+        . S OUTCNT=OUTCNT+1,^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=LINE
+        S OUTCNT=OUTCNT+1,ABLINE=OUTCNT
+        S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)="0^0^0"
+        ;
+        S (ABTCNT,ATSEQ)=0
+        F  S ATSEQ=$O(^TMP("LR7OG",$J,"ABTSEQ",ATSEQ)) Q:ATSEQ<1  D
+        . S ABTCNT=ABTCNT+1
+        . S $P(^TMP("LR7OG",$J,"ABTSEQ",ATSEQ),U)=ABTCNT
+        . S OUTCNT=OUTCNT+1
+        . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=^TMP("LR7OG",$J,"ABTSEQ",ATSEQ)
+        ;
+        S (ABDCNT,ADSEQ)=0
+        F  S ADSEQ=$O(^TMP("LR7OG",$J,"ABDSEQ",ADSEQ)) Q:ADSEQ<1  D
+        . S ABDCNT=ABDCNT+1
+        . S $P(^TMP("LR7OG",$J,"ABDSEQ",ADSEQ),U)=ABDCNT
+        . S OUTCNT=OUTCNT+1
+        . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=^TMP("LR7OG",$J,"ABDSEQ",ADSEQ)
+        ;
+        S (ABCNT,ADSEQ)=0
+        F  S ADSEQ=$O(^TMP("LR7OG",$J,"ABDATA",ADSEQ)) Q:ADSEQ<1  D
+        . S ADCNT=+^TMP("LR7OG",$J,"ABDSEQ",ADSEQ)
+        . S ATSEQ=0
+        .  F  S ATSEQ=$O(^TMP("LR7OG",$J,"ABDATA",ADSEQ,ATSEQ)) Q:ATSEQ<1  D
+        . . S ATCNT=+^TMP("LR7OG",$J,"ABTSEQ",ATSEQ)
+        . . S ABCNT=ABCNT+1
+        . . S OUTCNT=OUTCNT+1
+        . . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=ADCNT_U_ATCNT_U_^TMP("LR7OG",$J,"ABDATA",ADSEQ,ATSEQ)
+        ;
+        S ^TMP("LR7OGX",$J,"OUTPUT",ABLINE)=ABTCNT_U_ABDCNT_U_ABCNT
+        S $P(^TMP("LR7OGX",$J,"OUTPUT",1),U,4)=OUTCNT
+        S TESTSEQ=0
+         F  S TESTSEQ=$O(^TMP("LR7OG",$J,"TESTSPEC",TESTSEQ)) Q:TESTSEQ<1  D
+        . S SPEC=0
+        . F  S SPEC=$O(^TMP("LR7OG",$J,"TESTSPEC",TESTSEQ,SPEC)) Q:SPEC<1  S LINE=^(SPEC) D
+        . . S OUTCNT=OUTCNT+1
+        . . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=LINE
+        S $P(^TMP("LR7OGX",$J,"OUTPUT",1),U,5)=OUTCNT
+        ;
+        S NUM=0
+        F  S NUM=$O(^TMP("LR7OG",$J,"COMMENT",NUM)) Q:NUM<1  S LINE=^(NUM) D
+        . S OUTCNT=OUTCNT+1
+        . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=LINE
+        K ^TMP("LR7OG",$J)
+        Q
+        ;
+        ;
+TESTSPEC(CHSUB,SPEC,SPECNAME,AGE,SEX)   ;
+        N RANGE,TESTNAME,TESTNUM,TESTSEQ,UNITS
+        S TESTSEQ=+$P(^TMP("LR7OG",$J,"TEST",CHSUB),U),TESTNUM=+$P(^(CHSUB),U,2),TESTNAME=$P(^(CHSUB),U,3)
+        I $D(^TMP("LR7OG",$J,"TESTSPEC",TESTSEQ,SPEC)) Q
+        D URANGE^LR7OGU(TESTNUM,SPEC,AGE,SEX,.UNITS,.RANGE)
+        S ^TMP("LR7OG",$J,"TESTSPEC",TESTSEQ,SPEC)=TESTNUM_U_SPECNAME_U_SPEC_U_UNITS_U_$P(RANGE," - ")_U_$P($P(RANGE," - ",2)," (")
+        Q
+LR7OGG ;DALOI/STAFF- Interim report rpc grid ; Feb 9, 2005
+ ;;5.2;LAB SERVICE;**187,290**;Sep 27, 1994
+ ;
+TEST ; test use only
+ N CNT,I K ^TMP("LR7OGX",$J)
+ S ^TMP("LR7OGX",$J,"INPUT",1)="2^2970202^2920202"
+ S CNT=1
+ ;F I=1:1:10 I $D(^LAB(60,I,0)) S CNT=CNT+1,^TMP("LR7OGX",$J,"INPUT",CNT)=I
+ F I=7,173,9,1 I $D(^LAB(60,I,0)) S CNT=CNT+1,^TMP("LR7OGX",$J,"INPUT",CNT)=I
+ D GRIDDATA
+ S I=0 F  S I=$O(^TMP("LR7OGX",$J,"OUTPUT",I)) Q:I<1  W !,^(I)
+ K ^TMP("LR7OGX",$J)
+ Q
+ ;
+GRID(ROOT,DFN,DATE1,DATE2,SPEC,TESTS) ; from ORWLRR
+ N CNT,NUM
+ K ^TMP("LR7OGX",$J,"INPUT"),^("OUTPUT")
+ S ROOT=$NA(^TMP("LR7OGX",$J,"OUTPUT"))
+ S ^TMP("LR7OGX",$J,"INPUT",1)=DFN_U_DATE1_U_DATE2_U_+SPEC
+ S CNT=1,NUM=0 F  S NUM=$O(TESTS(NUM)) Q:NUM<1  D
+ .S CNT=CNT+1
+ .S ^TMP("LR7OGX",$J,"INPUT",CNT)=+TESTS(NUM)
+ D GRIDDATA
+ Q
+ ;
+GRIDDATA ;
+ ; input format
+ ; ^TMP("LR7OGX",$J,"INPUT",1)=dfn^start date^end date^spec^all tests
+ ; ^TMP("LR7OGX",$J,"INPUT",#)=test#  (tests displayed in this order)
+ ;   (these tests should, be atomic, subscript - ch, type - both or output)
+ ;
+ S ^TMP("LR7OGX",$J,"OUTPUT",1)="0^0^0^1"
+ N ABCNT,ABDCNT,ABLINE,ABTCNT,ABTLINE,ADCNT,ADSEQ,AGE,ATCNT,ATSEQ,CDT,CHSUB,COMCNT,COMMENT,DATACNT,DATESEQ,DFN,EDATE,EDT,FLAG,IDT
+ N LINE,LRCW,LRDFN,LRX,NUM,ONLYSPEC,OUTCNT,PNM,PRNTCODE,RESULT,SDATE,SEX,SPEC,SPECNAME,TESTNAME,TESTNUM,TESTSEQ,TESTZERO,X,ZERO
+ K ^TMP("LR7OG",$J)
+ S DFN=+^TMP("LR7OGX",$J,"INPUT",1),SDATE=+$P(^(1),U,2),EDATE=+$P(^(1),U,3),ONLYSPEC=+$P(^(1),U,4)
+ D DEMO^LR7OGU(DFN,.LRDFN,.PNM,.AGE,.SEX)
+ Q:'DFN  Q:'SDATE  Q:'EDATE  Q:'LRDFN
+ S OUTCNT=1,(ADCNT,ADSEQ,ATCNT,ATSEQ,COMCNT,DATACNT,DATESEQ,TESTSEQ,TCNT)=0
+ S NUM=1
+ F  S NUM=$O(^TMP("LR7OGX",$J,"INPUT",NUM)) Q:NUM<1  S TESTNUM=+^(NUM) D
+ . S TESTZERO=$G(^LAB(60,TESTNUM,0))
+ . S CHSUB=$P($P(TESTZERO,U,5),";",2)
+ . I 'CHSUB Q
+ . S TESTNAME=$P($G(^LAB(60,TESTNUM,.1)),U),PRNTCODE=$P($G(^(.1)),U,3)
+ . I TESTNAME="" S TESTNAME=$P(TESTZERO,U)
+ . S TESTSEQ=TESTSEQ+1
+ . S LINE=TESTSEQ_U_TESTNUM_U_TESTNAME_U_PRNTCODE
+ . S ^TMP("LR7OG",$J,"TEST",CHSUB)=LINE
+ . S OUTCNT=OUTCNT+1
+ . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=LINE
+ S ^TMP("LR7OGX",$J,"OUTPUT",1)=TESTSEQ
+ S EDATE=EDATE\1
+ S IDT=9999999-SDATE,EDT=9999999-EDATE
+ F  S IDT=$O(^LR(LRDFN,"CH",IDT)) Q:IDT<1  Q:IDT>EDT  D
+ . S ZERO=^LR(LRDFN,"CH",IDT,0)
+ . I '$P(ZERO,U,3) Q
+ . S CDT=+ZERO,SPEC=+$P(ZERO,U,5),SPECNAME=$P($G(^LAB(61,SPEC,0)),U),COMMENT=$S($O(^LR(LRDFN,"CH",IDT,1,0)):"**",1:"")
+ . I ONLYSPEC,SPEC'=ONLYSPEC Q
+ . S CHSUB=1
+ . F  S CHSUB=$O(^LR(LRDFN,"CH",IDT,CHSUB)) Q:CHSUB=""  D
+ . . I '$D(^TMP("LR7OG",$J,"TEST",CHSUB)) Q
+ . . I '$D(^TMP("LR7OG",$J,"DATE",IDT)) S ^(IDT)="" D
+ . . . S DATESEQ=DATESEQ+1
+ . . . S OUTCNT=OUTCNT+1
+ . . . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=DATESEQ_U_CDT_U_SPEC_U_SPECNAME_U_COMMENT
+ . . . I COMMENT'="" D
+ . . . . S COMCNT=COMCNT+1
+ . . . . S ^TMP("LR7OG",$J,"COMMENT",COMCNT)=$P($$FMTE^XLFDT(CDT),":",1,2)_" ** Comments:"
+ . . . . S NUM=0
+ . . . . F  S NUM=$O(^LR(LRDFN,"CH",IDT,1,NUM)) Q:NUM<1  S LINE=$G(^(NUM,0)) D
+ . . . . . S COMCNT=COMCNT+1
+ . . . . . S ^TMP("LR7OG",$J,"COMMENT",COMCNT)=LINE
+ . . . . S COMCNT=COMCNT+1
+ . . . . S ^TMP("LR7OG",$J,"COMMENT",COMCNT)=""
+ . . S LRX=$$TSTRES^LRRPU(LRDFN,"CH",IDT,CHSUB,"")
+ . . S RESULT=$P(LRX,"^"),FLAG=$P(LRX,U,2)
+ . . S PRNTCODE=$P(^TMP("LR7OG",$J,"TEST",CHSUB),U,4)
+ . . I PRNTCODE'="" S X=RESULT,LRCW=8 S @("RESULT="_PRNTCODE)
+ . . E  S RESULT=$J(RESULT,8)
+ . . S RESULT=$$STRIP^LR7OGU(RESULT)
+ . . I FLAG'="" D
+ . . . S ABTLINE=^TMP("LR7OG",$J,"TEST",CHSUB)
+ . . . I '$D(^TMP("LR7OG",$J,"ABTSEQ",+ABTLINE)) S ^(+ABTLINE)=U_$P(ABTLINE,U,2,3)
+ . . . I '$D(^TMP("LR7OG",$J,"ABDSEQ",IDT)) S ^(IDT)=U_CDT_U_SPEC_U_SPECNAME_U_COMMENT
+ . . . S ^TMP("LR7OG",$J,"ABDATA",IDT,+ABTLINE)=RESULT_U_FLAG
+ . . S TESTSEQ=+^TMP("LR7OG",$J,"TEST",CHSUB)
+ . . S DATACNT=DATACNT+1
+ . . S ^TMP("LR7OG",$J,"DATA",DATACNT)=DATESEQ_U_TESTSEQ_U_RESULT_U_FLAG
+ . . D TESTSPEC(CHSUB,SPEC,SPECNAME,AGE,SEX)
+ S $P(^TMP("LR7OGX",$J,"OUTPUT",1),U,2,3)=DATESEQ_U_DATACNT
+ S DATACNT=0
+ F  S DATACNT=$O(^TMP("LR7OG",$J,"DATA",DATACNT)) Q:DATACNT<1  S LINE=^(DATACNT) D
+ . S OUTCNT=OUTCNT+1,^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=LINE
+ S OUTCNT=OUTCNT+1,ABLINE=OUTCNT
+ S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)="0^0^0"
+ ;
+ S (ABTCNT,ATSEQ)=0
+ F  S ATSEQ=$O(^TMP("LR7OG",$J,"ABTSEQ",ATSEQ)) Q:ATSEQ<1  D
+ . S ABTCNT=ABTCNT+1
+ . S $P(^TMP("LR7OG",$J,"ABTSEQ",ATSEQ),U)=ABTCNT
+ . S OUTCNT=OUTCNT+1
+ . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=^TMP("LR7OG",$J,"ABTSEQ",ATSEQ)
+ ;
+ S (ABDCNT,ADSEQ)=0
+ F  S ADSEQ=$O(^TMP("LR7OG",$J,"ABDSEQ",ADSEQ)) Q:ADSEQ<1  D
+ . S ABDCNT=ABDCNT+1
+ . S $P(^TMP("LR7OG",$J,"ABDSEQ",ADSEQ),U)=ABDCNT
+ . S OUTCNT=OUTCNT+1
+ . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=^TMP("LR7OG",$J,"ABDSEQ",ADSEQ)
+ ;
+ S (ABCNT,ADSEQ)=0
+ F  S ADSEQ=$O(^TMP("LR7OG",$J,"ABDATA",ADSEQ)) Q:ADSEQ<1  D
+ . S ADCNT=+^TMP("LR7OG",$J,"ABDSEQ",ADSEQ)
+ . S ATSEQ=0
+ .  F  S ATSEQ=$O(^TMP("LR7OG",$J,"ABDATA",ADSEQ,ATSEQ)) Q:ATSEQ<1  D
+ . . S ATCNT=+^TMP("LR7OG",$J,"ABTSEQ",ATSEQ)
+ . . S ABCNT=ABCNT+1
+ . . S OUTCNT=OUTCNT+1
+ . . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=ADCNT_U_ATCNT_U_^TMP("LR7OG",$J,"ABDATA",ADSEQ,ATSEQ)
+ ;
+ S ^TMP("LR7OGX",$J,"OUTPUT",ABLINE)=ABTCNT_U_ABDCNT_U_ABCNT
+ S $P(^TMP("LR7OGX",$J,"OUTPUT",1),U,4)=OUTCNT
+ S TESTSEQ=0
+  F  S TESTSEQ=$O(^TMP("LR7OG",$J,"TESTSPEC",TESTSEQ)) Q:TESTSEQ<1  D
+ . S SPEC=0
+ . F  S SPEC=$O(^TMP("LR7OG",$J,"TESTSPEC",TESTSEQ,SPEC)) Q:SPEC<1  S LINE=^(SPEC) D
+ . . S OUTCNT=OUTCNT+1
+ . . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=LINE
+ S $P(^TMP("LR7OGX",$J,"OUTPUT",1),U,5)=OUTCNT
+ ;
+ S NUM=0
+ F  S NUM=$O(^TMP("LR7OG",$J,"COMMENT",NUM)) Q:NUM<1  S LINE=^(NUM) D
+ . S OUTCNT=OUTCNT+1
+ . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=LINE
+ K ^TMP("LR7OG",$J)
+ Q
+ ;
+ ;
+TESTSPEC(CHSUB,SPEC,SPECNAME,AGE,SEX) ;
+ N RANGE,TESTNAME,TESTNUM,TESTSEQ,UNITS
+ S TESTSEQ=+$P(^TMP("LR7OG",$J,"TEST",CHSUB),U),TESTNUM=+$P(^(CHSUB),U,2),TESTNAME=$P(^(CHSUB),U,3)
+ I $D(^TMP("LR7OG",$J,"TESTSPEC",TESTSEQ,SPEC)) Q
+ D URANGE^LR7OGU(TESTNUM,SPEC,AGE,SEX,.UNITS,.RANGE)
+ S ^TMP("LR7OG",$J,"TESTSPEC",TESTSEQ,SPEC)=TESTNUM_U_SPECNAME_U_SPEC_U_UNITS_U_$P(RANGE," - ")_U_$P($P(RANGE," - ",2)," (")
+ Q

WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LR7OGMG.m

-              r613
+              r623
+LR7OGMG ;DALOI/STAFF- Interim report rpc memo grid ;July 19, 2006
+        ;;5.2;LAB SERVICE;**187,230,286,290,331,364**;Sep 27, 1994;Build 3
+        ;
+GRID(OUTCNT)    ; from LR7OGMC
+        N ACC,AGE,CDT,CMNT,DATA,DOC,FLAG,IDT,INTP,LINE,LRCW,LRX,MPLS,PLS,PORDER,PRNTCODE,RANGE,SEX,SPEC,SUB,TCNT,TESTNAME,TESTNUM
+        N UNITS,VALUE,X,ZERO,INEXACT,DISPDATE
+        ; the variables AGE, SEX, LRCW, and X are used withing the lab's print codes and ref ranges
+        K ^TMP("LRMPLS",$J)
+        S AGE=$P(^TMP("LR7OG",$J,"G"),U,4),SEX=$P(^("G"),U,5),LRCW=$P(^("G"),U,6)
+        S CDT=+$O(^TMP("LR7OG",$J,"TP",0)) Q:'CDT
+        S IDT=9999999-CDT
+        S ZERO=$S($D(^TMP("LR7OG",$J,"TP",CDT))#2:^(CDT),1:"")
+        I '$P(ZERO,U,3) Q
+        S SPEC=+$P(ZERO,U,5)
+        S INEXACT=$P(ZERO,U,2),DISPDATE=$S(INEXACT:CDT\1,1:CDT)
+        S DOC=$$NAME^LR7OGMP(+$P(ZERO,U,10))
+        S ACC=$P(ZERO,U,6)
+        S $P(^TMP("LR7OGX",$J,"OUTPUT",1),U,4,6)=SPEC_U_$P($G(^LAB(61,SPEC,0)),U)_U_ACC_U_DOC
+        S $P(^TMP("LR7OGX",$J,"OUTPUT",1),U,10)=DISPDATE
+        S (TCNT,MPLS,PORDER,PLS)=0
+        S PLS=$O(^TMP("LRPLS",$J,0))
+        I $O(^TMP("LRPLS",$J,PLS)) S MPLS=1 ; multiple performing labs
+        F  S PORDER=$O(^TMP("LR7OG",$J,"TP",CDT,PORDER)) Q:PORDER'>0  S DATA=^(PORDER) D
+        . I $P(DATA,U,7)="" Q
+        . S TCNT=TCNT+1
+        . S TESTNUM=+DATA,TESTNAME=$P(DATA,U,2),PRNTCODE=$P(DATA,U,5),SUB=$P(DATA,U,6),FLAG=$P(DATA,U,8),X=$P(DATA,U,7),UNITS=$P(DATA,U,9),RANGE=$P(DATA,U,10),PLS=$P(DATA,U,11)
+        . I MPLS,PLS S ^TMP("LRMPLS",$J,PLS,TESTNAME)=""
+        . I PRNTCODE="" S VALUE=$J(X,8)
+        . E  S @("VALUE="_PRNTCODE)
+        . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=TESTNUM_U_TESTNAME_U_VALUE_U_FLAG_U_UNITS_U_RANGE
+        . S OUTCNT=OUTCNT+1
+        S $P(^TMP("LR7OGX",$J,"OUTPUT",1),U)=TCNT
+        ;
+        S PORDER=0
+        F  S PORDER=$O(^TMP("LR7OG",$J,"TP",CDT,PORDER)) Q:PORDER'>0  S DATA=^(PORDER) D
+        . I $O(^TMP("LR7OG",$J,"TP",CDT,PORDER,0))>0 D
+        . . S TESTNAME=$P(DATA,U,3)
+        . . S INTP=0
+        . . F  S INTP=+$O(^TMP("LR7OG",$J,"TP",CDT,PORDER,INTP)) Q:INTP<1  D
+        . . . S LINE=TESTNAME_" Eval: "_^TMP("LR7OG",$J,"TP",CDT,PORDER,INTP)
+        . . . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=LINE
+        . . . S OUTCNT=OUTCNT+1
+        ;
+        I $D(^TMP("LR7OG",$J,"TP",CDT,"C")) D
+        . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)="Comment: "
+        . S OUTCNT=OUTCNT+1,CMNT=0
+        . F  S CMNT=+$O(^TMP("LR7OG",$J,"TP",CDT,"C",CMNT)) Q:CMNT<1  S LINE=^(CMNT) D
+        . . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)="   "_LINE
+        . . S OUTCNT=OUTCNT+1
+        ;
+        D PLS
+        Q
+        ;
+        ;
+PLS     ; List performing laboratories
+        ; If multiple performing labs then list tests associated with each lab.
+        ;
+        N CNT,LINE,LRPLS,X
+        S (CNT,LRPLS)=0
+        F  S LRPLS=$O(^TMP("LRPLS",$J,LRPLS)) Q:LRPLS<1  D
+        . I CNT S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=" ",OUTCNT=OUTCNT+1
+        . I $D(^TMP("LRMPLS",$J,LRPLS)) D
+        . . S TESTNAME="",LINE="For test(s): "
+        . . F  S TESTNAME=$O(^TMP("LRMPLS",$J,LRPLS,TESTNAME)) Q:TESTNAME=""  D
+        . . . I ($L(LINE)+$L(TESTNAME))>240 D
+        . . . . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=LINE
+        . . . . S OUTCNT=OUTCNT+1,LINE=""
+        . . . S LINE=LINE_TESTNAME_", "
+        . . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=LINE,OUTCNT=OUTCNT+1
+        . S LINE=$$NAME^XUAF4(LRPLS)
+        . S X=$$PADD^XUAF4(LRPLS)
+        . S LINE=LINE_"  "_$P(X,U)_"  "_$P(X,U,2)_", "_$P(X,U,3)_" "_$P(X,U,4)
+        . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)="Performing Lab: "_LINE
+        . S OUTCNT=OUTCNT+1,CNT=CNT+1
+        ;
+        K ^TMP("LRPLS",$J),^TMP("LRMPLS",$J)
+        Q
+LR7OGMG ;DALOI/STAFF- Interim report rpc memo grid ;July 19, 2006
+ ;;5.2;LAB SERVICE;**187,230,286,290,331**;Sep 27, 1994;Build 7
+ ;
+GRID(OUTCNT) ; from LR7OGMC
+ N ACC,AGE,CDT,CMNT,DATA,DOC,FLAG,IDT,INTP,LINE,LRCW,LRX,MPLS,PLS,PORDER,PRNTCODE,RANGE,SEX,SPEC,SUB,TCNT,TESTNAME,TESTNUM
+ N UNITS,VALUE,X,ZERO
+ ; the variables AGE, SEX, LRCW, and X are used withing the lab's print codes and ref ranges
+ K ^TMP("LRMPLS",$J)
+ S AGE=$P(^TMP("LR7OG",$J,"G"),U,4),SEX=$P(^("G"),U,5),LRCW=$P(^("G"),U,6)
+ S CDT=+$O(^TMP("LR7OG",$J,"TP",0)) Q:'CDT
+ S IDT=9999999-CDT
+ S ZERO=$S($D(^TMP("LR7OG",$J,"TP",CDT))#2:^(CDT),1:"")
+ I '$P(ZERO,U,3) Q
+ S SPEC=+$P(ZERO,U,5)
+ S DOC=$$NAME^LR7OGMP(+$P(ZERO,U,10))
+ S ACC=$P(ZERO,U,6)
+ S $P(^TMP("LR7OGX",$J,"OUTPUT",1),U,4,6)=SPEC_U_$P($G(^LAB(61,SPEC,0)),U)_U_ACC_U_DOC
+ S (TCNT,MPLS,PORDER,PLS)=0
+ S PLS=$O(^TMP("LRPLS",$J,0))
+ I $O(^TMP("LRPLS",$J,PLS)) S MPLS=1 ; multiple performing labs
+ F  S PORDER=$O(^TMP("LR7OG",$J,"TP",CDT,PORDER)) Q:PORDER'>0  S DATA=^(PORDER) D
+ . I $P(DATA,U,7)="" Q
+ . S TCNT=TCNT+1
+ . S TESTNUM=+DATA,TESTNAME=$P(DATA,U,2),PRNTCODE=$P(DATA,U,5),SUB=$P(DATA,U,6),FLAG=$P(DATA,U,8),X=$P(DATA,U,7),UNITS=$P(DATA,U,9),RANGE=$P(DATA,U,10),PLS=$P(DATA,U,11)
+ . I MPLS,PLS S ^TMP("LRMPLS",$J,PLS,TESTNAME)=""
+ . I PRNTCODE="" S VALUE=$J(X,8)
+ . E  S @("VALUE="_PRNTCODE)
+ . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=TESTNUM_U_TESTNAME_U_VALUE_U_FLAG_U_UNITS_U_RANGE
+ . S OUTCNT=OUTCNT+1
+ S $P(^TMP("LR7OGX",$J,"OUTPUT",1),U)=TCNT
+ ;
+ S PORDER=0
+ F  S PORDER=$O(^TMP("LR7OG",$J,"TP",CDT,PORDER)) Q:PORDER'>0  S DATA=^(PORDER) D
+ . I $O(^TMP("LR7OG",$J,"TP",CDT,PORDER,0))>0 D
+ . . S TESTNAME=$P(DATA,U,3)
+ . . S INTP=0
+ . . F  S INTP=+$O(^TMP("LR7OG",$J,"TP",CDT,PORDER,INTP)) Q:INTP<1  D
+ . . . S LINE=TESTNAME_" Eval: "_^TMP("LR7OG",$J,"TP",CDT,PORDER,INTP)
+ . . . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=LINE
+ . . . S OUTCNT=OUTCNT+1
+ ;
+ I $D(^TMP("LR7OG",$J,"TP",CDT,"C")) D
+ . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)="Comment: "
+ . S OUTCNT=OUTCNT+1,CMNT=0
+ . F  S CMNT=+$O(^TMP("LR7OG",$J,"TP",CDT,"C",CMNT)) Q:CMNT<1  S LINE=^(CMNT) D
+ . . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)="   "_LINE
+ . . S OUTCNT=OUTCNT+1
+ ;
+ D PLS
+ Q
+ ;
+ ;
+PLS ; List performing laboratories
+ ; If multiple performing labs then list tests associated with each lab.
+ ;
+ N CNT,LINE,LRPLS,X
+ S (CNT,LRPLS)=0
+ F  S LRPLS=$O(^TMP("LRPLS",$J,LRPLS)) Q:LRPLS<1  D
+ . I CNT S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=" ",OUTCNT=OUTCNT+1
+ . I $D(^TMP("LRMPLS",$J,LRPLS)) D
+ . . S TESTNAME="",LINE="For test(s): "
+ . . F  S TESTNAME=$O(^TMP("LRMPLS",$J,LRPLS,TESTNAME)) Q:TESTNAME=""  D
+ . . . I ($L(LINE)+$L(TESTNAME))>240 D
+ . . . . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=LINE
+ . . . . S OUTCNT=OUTCNT+1,LINE=""
+ . . . S LINE=LINE_TESTNAME_", "
+ . . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=LINE,OUTCNT=OUTCNT+1
+ . S LINE=$$NAME^XUAF4(LRPLS)
+ . S X=$$PADD^XUAF4(LRPLS)
+ . S LINE=LINE_"  "_$P(X,U)_"  "_$P(X,U,2)_", "_$P(X,U,3)_" "_$P(X,U,4)
+ . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)="Performing Lab: "_LINE
+ . S OUTCNT=OUTCNT+1,CNT=CNT+1
+ ;
+ K ^TMP("LRPLS",$J),^TMP("LRMPLS",$J)
+ Q

WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LR7OGMM.m

-              r613
+              r623
+LR7OGMM ;SLC/STAFF- Interim report rpc memo micro ;5/20/97  18:52
+        ;;5.2;LAB SERVICE;**187,312,364**;Sep 27, 1994;Build 3
+        ;
+MI(LRDFN,IDT,MICROSUB,ALL,OUTCNT,FORMAT,DONE)   ; from LR7OGM
+        N MISUB,OK,ZERO,INEXACT,DISPDATE,XDT
+        I '$D(^LR(LRDFN,"MI",IDT)) Q
+        S OK=ALL
+        I 'OK S MISUB=0 F  S MISUB=+$O(MICROSUB(MISUB)) Q:MISUB<1  I $D(^LR(LRDFN,"MI",IDT,MISUB)) S OK=1 Q
+        I 'OK Q
+        I $G(FORMAT) D
+        .S XDT=9999999-IDT
+        .S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)="^MI^"_XDT D
+        ..; determine if collection time is "inexact" and put the
+        ..; collection day/time that is to be displayed in piece 10
+        ..S ZERO=$G(^LR(LRDFN,"MI",IDT,0)) Q:ZERO=""
+        ..S INEXACT=$P(ZERO,U,2)
+        ..S DISPDATE=$S(INEXACT:XDT\1,1:XDT)
+        ..S $P(^TMP("LR7OGX",$J,"OUTPUT",OUTCNT),U,10)=DISPDATE
+        .S OUTCNT=OUTCNT+1
+        .S DONE=1
+        D MIC(LRDFN,IDT,.OUTCNT)
+        Q
+        ;
+MIC(LRDFN,LRIDT,OUTCNT) ;
+        N AGE,GCNT,GIOM,LINE,LREND,LRONESPC,LRONETST,NUM,SEX
+        S GCNT=0,GIOM=80,LREND=0,LRONESPC="",LRONETST=0
+        S AGE=$P(^TMP("LR7OG",$J,"G"),U,5),SEX=$P(^("G"),U,6)
+        ; new variables used by LR7OSMZ0
+        N %,A,A8,AB,B,B1,B2,B3,C,CCNT,DIC,DZ,I,IA,II,INC,J,K,LR1PASS,LR2ORMOR,LRAA,LRABCNT,LRACC,LRACNT,LRAD,LRADM,LRADX,LRAFS,LRAMT,LRAN,LRAO,LRAX
+        N LRBN,LRBRR,LRBUG,LRCMNT,LRCOMTAB,LRCS,LRDCOM,LRDOC,LRDRTM1,LRDRTM2,LREF,LRFLAG,LRFMT,LRGRM,LRIFN,LRINT,LRJ02,LRLABKY,LRLLT,LRMYC,LRNS,LRNUM
+        N LRORG,LRPAR,LRPATLOC,LRPC,LRPG,LRPRE,LRPRINT,LRQU,LRRC,LRRES,LRSB,LRSBC1,LRSBC2,LRSET,LRSIC1,LRSIC2,LRSET,LRSIC1,LRSIC2,LRSPEC,LRSSD,LRST
+        N LRTA,LRTB,LRTBA,LRTBC,LRTBS,LRTK,LRTS,LRTSTS,LRTUS,LRUS,LRWRD,LRWRDVEW,N,S1,SP,X,X1,Y,Y1
+        K DIC,LR1PASS,LRBUG,LRDCOM,LRINT,LRRES,LRTS K ^TMP("LR",$J),^TMP("LRC",$J),^TMP("LRT",$J)
+        D EN1^LR7OSMZ0
+        I '$O(^TMP("LRC",$J,0)) Q
+        S NUM=0 F  S NUM=$O(^TMP("LRC",$J,NUM)) Q:NUM<1  S LINE=^(NUM,0) D
+        .S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=LINE,OUTCNT=OUTCNT+1
+        S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)="===============================================================================",OUTCNT=OUTCNT+1
+        K ^TMP("LR",$J),^TMP("LRC",$J),^TMP("LRT",$J)
+        Q
+LR7OGMM ;SLC/STAFF- Interim report rpc memo micro ;5/20/97  18:52
+ ;;5.2;LAB SERVICE;**187,312**;Sep 27, 1994
+ ;
+MI(LRDFN,IDT,MICROSUB,ALL,OUTCNT,FORMAT,DONE) ; from LR7OGM
+ N MISUB,OK
+ I '$D(^LR(LRDFN,"MI",IDT)) Q
+ S OK=ALL
+ I 'OK S MISUB=0 F  S MISUB=+$O(MICROSUB(MISUB)) Q:MISUB<1  I $D(^LR(LRDFN,"MI",IDT,MISUB)) S OK=1 Q
+ I 'OK Q
+ I $G(FORMAT) D
+ .S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)="^MI^"_(9999999-IDT)
+ .S OUTCNT=OUTCNT+1
+ .S DONE=1
+ D MIC(LRDFN,IDT,.OUTCNT)
+ Q
+ ;
+MIC(LRDFN,LRIDT,OUTCNT) ;
+ N AGE,GCNT,GIOM,LINE,LREND,LRONESPC,LRONETST,NUM,SEX
+ S GCNT=0,GIOM=80,LREND=0,LRONESPC="",LRONETST=0
+ S AGE=$P(^TMP("LR7OG",$J,"G"),U,5),SEX=$P(^("G"),U,6)
+ ; new variables used by LR7OSMZ0
+ N %,A,A8,AB,B,B1,B2,B3,C,CCNT,DIC,DZ,I,IA,II,INC,J,K,LR1PASS,LR2ORMOR,LRAA,LRABCNT,LRACC,LRACNT,LRAD,LRADM,LRADX,LRAFS,LRAMT,LRAN,LRAO,LRAX
+ N LRBN,LRBRR,LRBUG,LRCMNT,LRCOMTAB,LRCS,LRDCOM,LRDOC,LRDRTM1,LRDRTM2,LREF,LRFLAG,LRFMT,LRGRM,LRIFN,LRINT,LRJ02,LRLABKY,LRLLT,LRMYC,LRNS,LRNUM
+ N LRORG,LRPAR,LRPATLOC,LRPC,LRPG,LRPRE,LRPRINT,LRQU,LRRC,LRRES,LRSB,LRSBC1,LRSBC2,LRSET,LRSIC1,LRSIC2,LRSET,LRSIC1,LRSIC2,LRSPEC,LRSSD,LRST
+ N LRTA,LRTB,LRTBA,LRTBC,LRTBS,LRTK,LRTS,LRTSTS,LRTUS,LRUS,LRWRD,LRWRDVEW,N,S1,SP,X,X1,Y,Y1
+ K DIC,LR1PASS,LRBUG,LRDCOM,LRINT,LRRES,LRTS K ^TMP("LR",$J),^TMP("LRC",$J),^TMP("LRT",$J)
+ D EN1^LR7OSMZ0
+ I '$O(^TMP("LRC",$J,0)) Q
+ S NUM=0 F  S NUM=$O(^TMP("LRC",$J,NUM)) Q:NUM<1  S LINE=^(NUM,0) D
+ .S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=LINE,OUTCNT=OUTCNT+1
+ S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)="===============================================================================",OUTCNT=OUTCNT+1
+ K ^TMP("LR",$J),^TMP("LRC",$J),^TMP("LRT",$J)
+ Q

WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LR7OSAP2.m

-              r613
+              r623
+LR7OSAP2        ;ISL/RAB/WTY/KLL - Silent Routine for autopsy report;3/28/2002
+        ;;5.2;LAB SERVICE;**230,256,259,317,365**;Sep 27, 1994;Build 9
+        ;
+        ;Reference  to ^DD(63 supported by IA #999
+        ;
+EN(LRDFN)       ;
+        N CCNT,GIOM,XPOS,LR,LRSS,X,I,LRAU,LRS,VERIFIED,LRTEXT,LRPTR,X2
+        S XPOS=0,(LRS(5),LR("M"),CCNT)=1,LRSS="AU",GIOM=80
+        D EN^LRUA,^LRAPU
+        S X=$S($D(^LRO(69.2,+Y,0)):^(0),1:""),LRAU(3)=$P(X,"^",3),LRAU(4)=$P(X,"^",4)
+        D LINE,LN
+        S ^TMP("LRH",$J,"AUTOPSY")=GCNT,^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(28,CCNT,"---- AUTOPSY ----")
+        S VERIFIED=$P($G(^LR(LRDFN,"AU")),U,15)
+        I 'VERIFIED D  Q
+        . D LN
+        . S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,"Report not verified.")
+        D TIUCHK^LRAPUTL(.LRPTR,LRDFN,LRSS)
+        I +$G(LRPTR) D  Q
+        .D MAIN^LR7OSAP3(LRPTR)
+        D ZZ,LINE
+        I $D(^LR(LRDFN,84)) D
+        .D LN
+        .S LRTEXT="SUPPLEMENTARY REPORT HAS BEEN ADDED"
+        .S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(14,CCNT,"*+* "_LRTEXT_" *+*")
+        .D LN
+        .S LRTEXT="REFER TO BOTTOM OF REPORT"
+        .S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(19,CCNT,"*+* "_LRTEXT_" *+*")
+        .D LN
+        I $D(^LR(LRDFN,81)) D
+        . D LN
+        . S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,LRAU(3))
+        . D F(81)
+        I $D(^LR(LRDFN,82)) D
+        . D LN
+        . S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,LRAU(4))
+        . D F(82)
+        I $O(^LR(LRDFN,84,0)) D
+        . S I=0 F  S I=$O(^LR(LRDFN,84,I)) Q:'I  S X=^(I,0) D
+        .. ;Don't print supp date and text if supp has not been released
+        .. S X1=$P(X,"^",1),X2=$P(X,"^",2)
+        .. Q:'X2
+        .. D LINE,LN
+        .. S LRTEXT="SUPPLEMENTARY REPORT DATE: "_$$FMTE^XLFDT(X1,"1P")
+        .. S ^TMP("LRC",$J,GCNT,0)=LRTEXT
+        .. I $O(^LR(LRDFN,84,I,2,0)) D MODSR
+        .. D WRAP^LR7OSAP1("^LR("_LRDFN_",84,"_I_",1)",79)
+        Q:'$D(^LR(LRDFN,"AW"))&('$D(^("AY")))&('$D(^("AWI")))
+        D WT
+        D LRAPT3
+        ;Removed code that prints SNOMED codes per LR*5.2*259
+        Q
+MODSR   ;Modified Autopsy Supplementary Report Audit Info
+        N LRTEXT,LRSP1,LRSP2,LRFILE,LRIENS,LRR1,LRR2
+        S LRFILE=63.3242
+        D LN
+        S LRTEXT="SUPPLEMENTARY REPORT HAS BEEN ADDED/MODIFIED"
+        S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(14,CCNT,"*** "_LRTEXT_" ***")
+        D LN
+        S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,"(Added/Last modified: ")
+        S LRIENS=I_","_LRDFN_","
+        S LRSP1=0
+        F  S LRSP1=$O(^LR(LRDFN,84,I,2,LRSP1)) Q:'LRSP1  D
+        .S LRSP2=LRSP1
+        Q:'$D(^LR(LRDFN,84,I,2,LRSP2,0))
+        S LRS2=^LR(LRDFN,84,I,2,LRSP2,0),Y=+LRS2,LRS2A=$P(LRS2,"^",2),LRSGN=" typed by "
+        ;If supp rpt is released, display 'signed by' instead of 'typed by'
+        I $P(LRS2,"^",3) S Y=$P(LRS2,"^",4),LRS2A=$P(LRS2,"^",3),LRSGN=" signed by "
+        S LRS2A=$S($D(^VA(200,LRS2A,0)):$P(^(0),"^"),1:LRS2A)
+        D D^LRU
+        S LRR1=Y,LRR2=LRS2A
+        S ^(0)=^TMP("LRC",$J,GCNT,0)_LRR1_LRSGN_LRR2_")"
+        ;If RELEASED SUPP REPORT MODIFIED set to 1, display "NOT VERIFIED"
+        I $P(^LR(LRDFN,84,I,0),"^",3) D
+        .D LN
+        .S LRTEXT="NOT VERIFIED"
+        .S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(25,CCNT,"**-* "_LRTEXT_" *-**")
+        Q
+LN      ;Increment the counter
+        S GCNT=GCNT+1,CCNT=1
+        Q
+LINE    ;Fill in the global with bank lines
+        N X
+        D LN
+        S X="",$P(X," ",GIOM)="",^TMP("LRC",$J,GCNT,0)=X
+        Q
+F(NODE) ;;
+        D WRAP^LR7OSAP1("^LR("_LRDFN_","_NODE_")",79)
+        Q
+D       ;
+        N LRB,M,X
+        S LRB=0
+        F  S LRB=$O(^LR(LRDFN,"AY",I,1,LRB)) Q:'LRB  S X=^(LRB,0) D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(5,CCNT,$P(^LAB(61.4,+X,0),"^"))
+        S LRB=0
+        F  S LRB=$O(^LR(LRDFN,"AY",I,3,LRB)) Q:'LRB  S X=^(LRB,0) D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(5,CCNT,$P(^LAB(61.3,+X,0),"^"))
+        S LRB=0
+        F  S LRB=$O(^LR(LRDFN,"AY",I,4,LRB)) Q:'LRB  S X=^(LRB,0) D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(5,CCNT,$P(^LAB(61.5,+X,0),"^"))
+        S M=0
+        F  S M=$O(^LR(LRDFN,"AY",I,2,M)) Q:'M  S X=^(M,0) D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(5,CCNT,$P(^LAB(61.1,+X,0),"^")) D E
+        Q
+E       ;
+        N E
+        S E=0
+        F  S E=$O(^LR(LRDFN,"AY",I,2,M,1,E)) Q:'E  S X=^(E,0) D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(7,CCNT,$P(^LAB(61.2,+X,0),"^"))
+        Q
+HD      ;
+        D LINE
+        D LN
+        S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,"Organ/tissue:")_$$S^LR7OS(33,CCNT,"SNOMED CODING")
+        Q
+WT      ;
+        N B,X,OUT
+        I '$D(^LR(LRDFN,"AW")) D
+        . D LINE,LN
+        . S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(20,CCNT,"No organ weights entered.")
+        . D LINE
+        I $D(^LR(LRDFN,"AW")) S X=^("AW") D
+        . S B(9)=$P(X,"^",9),B(1)=$P(X,"^",11,99)
+        . D LINE,LN
+        . S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,"Rt--Lung--Lt  Liver Spleen  RT--Kidney--Lt  Brain  Body Wt(lb)    Ht(in)")
+        I $D(B) D
+        . D LN
+        . S OUT=$$S^LR7OS(XPOS,CCNT,$J($P(X,"^",3),4))_$$S^LR7OS(9,CCNT,$J($P(X,"^",4),4))_$$S^LR7OS(15,CCNT,$J($P(X,"^",5),5))_$$S^LR7OS(22,CCNT,$J($P(X,"^",6),5))_$$S^LR7OS(29,CCNT,$J($P(X,"^",7),4))_$$S^LR7OS(39,CCNT,$J($P(X,"^",8),4))
+        . S OUT=OUT_$$S^LR7OS(45,CCNT,$J($P(X,"^",10),4))_$$S^LR7OS(55,CCNT,$P(X,"^",2))_$$S^LR7OS(68,CCNT,$P(X,"^"))
+        . S ^TMP("LRC",$J,GCNT,0)=OUT
+        D LINE,LN
+        S ^TMP("LRC",$J,GCNT,0)=""
+        I $D(B) S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,"Heart(gm)")
+        I $D(^LR(LRDFN,"AV")) S X=^("AV"),B(2)=$P(X,"^",7,99),^(0)=^TMP("LRC",$J,GCNT,0)_$$S^LR7OS(12,CCNT,"TV(cm)  PV(cm)  MV(cm)  AV(cm)  RV(cm)  LV(cm)")
+        D LN
+        S ^TMP("LRC",$J,GCNT,0)=""
+        I $D(B(9)) S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,$J(B(9),5))
+        I $D(B(2)) D
+        . S OUT=$$S^LR7OS(12,CCNT,$J($P(X,"^"),4))_$$S^LR7OS(20,CCNT,$J($P(X,"^",2),4))_$$S^LR7OS(28,CCNT,$J($P(X,"^",3),4))_$$S^LR7OS(36,CCNT,$J($P(X,"^",4),4))_$$S^LR7OS(44,CCNT,$J($P(X,"^",5),4))_$$S^LR7OS(52,CCNT,$J($P(X,"^",6),4))
+        . S ^(0)=^TMP("LRC",$J,GCNT,0)_OUT
+        . D LINE,LN
+        . S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,"Cavities(ml): Rt--Pleural--Lt  Pericardial  Peritoneal")
+        . D LN
+        . S OUT=$$S^LR7OS(14,CCNT,$J($P(B(2),"^",2),4))_$$S^LR7OS(25,CCNT,$J($P(B(2),"^"),4))_$$S^LR7OS(33,CCNT,$J($P(B(2),"^",3),4))_$$S^LR7OS(45,CCNT,$J($P(B(2),"^",4),4))
+        . S ^TMP("LRC",$J,GCNT,0)=OUT
+        I $D(B(1)) F B=1:1:8 D
+        . I $P(B(1),"^",B) D
+        .. S X="25."_B
+        .. D LN
+        .. S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,$P(^DD(63,X,0),"^")_": "_$P(B(1),"^",B))
+        I $D(^LR(LRDFN,"AWI")) S Y=^("AWI") F B=1:1:5 I $P(Y,"^",B) D LN S X=$S(B=1:25.9,1:25.9_(B-1)),^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,$P(^DD(63,X,0),"^")_": "_$P(Y,"^",B))
+        Q
+ZZ      ;;
+        D LN
+        N OUT,X,LRLLOC,DA,A,B,C,LR,Y
+        S:$G(PNM)="" PNM=$P(^DPT(DFN,0),U) ;DBIA #10035
+        S OUT=$$S^LR7OS(XPOS,CCNT,"Acc #")_$$S^LR7OS(9,CCNT,"Date/time Died")_$$S^LR7OS(27,CCNT,"Age")_$$S^LR7OS(33,CCNT,"AUTOPSY DATA")_$$S^LR7OS(53,CCNT,"Date/time of Autopsy"),^TMP("LRC",$J,GCNT,0)=OUT
+        S X=^LR(LRDFN,"AU"),LRLLOC=$P(X,"^",8),DA=LRDFN
+        D D^LRAUAW
+        S Y=LR(63,12)
+        D D^LRU,LN
+        S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,($P(X,"^",6)_" "_Y))_$$S^LR7OS(26,CCNT,$J($P(X,"^",9),3))_$$S^LR7OS(33,CCNT,$G(PNM))
+        S Y=+X
+        D D^LRU
+        I Y'[1700 S ^(0)=^TMP("LRC",$J,GCNT,0)_$$S^LR7OS(53,CCNT,Y)
+        D LN
+        S ^TMP("LRC",$J,GCNT,0)=""
+        F X(1)=7,10 D
+        . S Y=$P(X,"^",X(1)),Y=$S(Y="":Y,$D(^VA(200,Y,0)):$P(^(0),"^"),1:Y)
+        . I Y]"" S ^TMP("LRC",$J,GCNT,0)=^TMP("LRC",$J,GCNT,0)_$S(X(1)=7:$$S^LR7OS(1,CCNT,"Resident: ")_Y,1:$$S^LR7OS(38,CCNT,"Senior: ")_Y)
+        Q
+LRAPT3  ;COPIED FROM ^LRAPT3
+        ;;
+        N A,C,X,T,F
+        S (F,A)=0
+        F  S A=$O(^LR(LRDFN,"AY",A)) Q:'A  D
+        .I $D(^LR(LRDFN,"AY",A,0)) S T=+^(0) D
+        ..S T(1)=$P($G(^LAB(61,T,0)),"^")
+        ..S C=0 F  S C=$O(^LR(LRDFN,"AY",A,5,C)) Q:'C  D
+        ...S X=^LR(LRDFN,"AY",A,5,C,0) D SP(X) S F=1
+        ;Removed code that prints ICD codes per LR*5.2*259
+        Q
+SP(NODE)        ;
+        N Y,E,X,A1,B
+        S Y=$P(NODE,"^",2),E=$P(NODE,"^",3),X=$P(NODE,"^")_":",A1=$P($P(LRAU("S"),X,2),";",1)
+        D D^LRU
+        S T(2)=Y
+        I 'F D LINE,LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,T(1))
+        D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,A1_" "_E_" Date: "_T(2))
+        D WRAP^LR7OSAP1("^LR("_LRDFN_",""AY"","_A_",5,"_C_",1)",80)
+        Q
+OUT     ;Show output
+        Q:'$D(^TMP("LRC",$J))
+        N I
+        S I=0
+        F  S I=$O(^TMP("LRC",$J,I)) Q:'I  W !,^(I,0)
+        Q
+LR7OSAP2 ;ISL/RAB/WTY/KLL -Silent Routine for autopsy report;3/28/2002
+ ;;5.2;LAB SERVICE;**230,256,259,317**;Sep 27, 1994
+ ;
+ ;Reference  to ^DD(63 supported by IA #999
+ ;
+EN(LRDFN) ;
+ N CCNT,GIOM,XPOS,LR,LRSS,X,I,LRAU,LRS,VERIFIED,LRTEXT,LRPTR,X2
+ S XPOS=0,(LRS(5),LR("M"),CCNT)=1,LRSS="AU",GIOM=80
+ D EN^LRUA,^LRAPU
+ S X=$S($D(^LRO(69.2,+Y,0)):^(0),1:""),LRAU(3)=$P(X,"^",3),LRAU(4)=$P(X,"^",4)
+ D LINE,LN
+ S ^TMP("LRH",$J,"AUTOPSY")=GCNT,^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(28,CCNT,"---- AUTOPSY ----")
+ S VERIFIED=$P($G(^LR(LRDFN,"AU")),U,15)
+ I 'VERIFIED D  Q
+ . D LN
+ . S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,"Report not verified.")
+ D TIUCHK^LRAPUTL(.LRPTR,LRDFN,LRSS)
+ I +$G(LRPTR) D  Q
+ .D MAIN^LR7OSAP3(LRPTR)
+ D ZZ,LINE
+ I $D(^LR(LRDFN,84)) D
+ .D LN
+ .S LRTEXT="SUPPLEMENTARY REPORT HAS BEEN ADDED"
+ .S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(14,CCNT,"*+* "_LRTEXT_" *+*")
+ .D LN
+ .S LRTEXT="REFER TO BOTTOM OF REPORT"
+ .S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(19,CCNT,"*+* "_LRTEXT_" *+*")
+ .D LN
+ I $D(^LR(LRDFN,81)) D
+ . D LN
+ . S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,LRAU(3))
+ . D F(81)
+ I $D(^LR(LRDFN,82)) D
+ . D LN
+ . S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,LRAU(4))
+ . D F(82)
+ I $O(^LR(LRDFN,84,0)) D
+ . S I=0 F  S I=$O(^LR(LRDFN,84,I)) Q:'I  S X=^(I,0) D
+ .. ;Don't print supp date and text if supp has not been released
+ .. S X1=$P(X,"^",1),X2=$P(X,"^",2)
+ .. Q:'X2
+ .. D LINE,LN
+ .. S LRTEXT="SUPPLEMENTARY REPORT DATE: "_$$FMTE^XLFDT(X1,"1P")
+ .. S ^TMP("LRC",$J,GCNT,0)=LRTEXT
+ .. I $O(^LR(LRDFN,84,I,2,0)) D MODSR
+ .. D WRAP^LR7OSAP1("^LR("_LRDFN_",84,"_I_",1)",79)
+ Q:'$D(^LR(LRDFN,"AW"))&('$D(^("AY")))&('$D(^("AWI")))
+ D WT
+ D LRAPT3
+ ;Removed code that prints SNOMED codes per LR*5.2*259
+ Q
+MODSR ;Modified Autopsy Supplementary Report Audit Info
+ N LRTEXT,LRSP1,LRSP2,LRFILE,LRIENS,LRR1,LRR2
+ S LRFILE=63.3242
+ D LN
+ S LRTEXT="SUPPLEMENTARY REPORT HAS BEEN ADDED/MODIFIED"
+ S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(14,CCNT,"*** "_LRTEXT_" ***")
+ D LN
+ S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,"(Added/Last modified: ")
+ S LRIENS=I_","_LRDFN_","
+ S LRSP1=0
+ F  S LRSP1=$O(^LR(LRDFN,84,I,2,LRSP1)) Q:'LRSP1  D
+ .S LRSP2=LRSP1
+ Q:'$D(^LR(LRDFN,84,I,2,LRSP2,0))
+ S LRS2=^(0),Y=+LRS2,LRS2A=$P(LRS2,"^",2),LRSGN=" typed by "
+ ;If supp rpt is released, display 'signed by' instead of 'typed by'
+ I $P(LRS2,"^",3) S Y=$P(LRS2,"^",4),LRS2A=$P(LRS2,"^",3),LRSGN=" signed by "
+ S LRS2A=$S($D(^VA(200,LRS2A,0)):$P(^(0),"^"),1:LRS2A)
+ D D^LRU
+ S LRR1=Y,LRR2=LRS2A
+ S ^(0)=^TMP("LRC",$J,GCNT,0)_LRR1_LRSGN_LRR2_")"
+ ;If RELEASED SUPP REPORT MODIFIED set to 1, display "NOT VERIFIED"
+ I $P(^LR(LRDFN,84,I,0),"^",3) D
+ .D LN
+ .S LRTEXT="NOT VERIFIED"
+ .S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(25,CCNT,"**-* "_LRTEXT_" *-**")
+ Q
+LN ;Increment the counter
+ S GCNT=GCNT+1,CCNT=1
+ Q
+LINE ;Fill in the global with bank lines
+ N X
+ D LN
+ S X="",$P(X," ",GIOM)="",^TMP("LRC",$J,GCNT,0)=X
+ Q
+F(NODE) ;;
+ D WRAP^LR7OSAP1("^LR("_LRDFN_","_NODE_")",79)
+ Q
+D ;
+ N LRB,M,X
+ S LRB=0
+ F  S LRB=$O(^LR(LRDFN,"AY",I,1,LRB)) Q:'LRB  S X=^(LRB,0) D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(5,CCNT,$P(^LAB(61.4,+X,0),"^"))
+ S LRB=0
+ F  S LRB=$O(^LR(LRDFN,"AY",I,3,LRB)) Q:'LRB  S X=^(LRB,0) D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(5,CCNT,$P(^LAB(61.3,+X,0),"^"))
+ S LRB=0
+ F  S LRB=$O(^LR(LRDFN,"AY",I,4,LRB)) Q:'LRB  S X=^(LRB,0) D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(5,CCNT,$P(^LAB(61.5,+X,0),"^"))
+ S M=0
+ F  S M=$O(^LR(LRDFN,"AY",I,2,M)) Q:'M  S X=^(M,0) D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(5,CCNT,$P(^LAB(61.1,+X,0),"^")) D E
+ Q
+E ;
+ N E
+ S E=0
+ F  S E=$O(^LR(LRDFN,"AY",I,2,M,1,E)) Q:'E  S X=^(E,0) D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(7,CCNT,$P(^LAB(61.2,+X,0),"^"))
+ Q
+HD ;
+ D LINE
+ D LN
+ S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,"Organ/tissue:")_$$S^LR7OS(33,CCNT,"SNOMED CODING")
+ Q
+WT ;
+ N B,X,OUT
+ I '$D(^LR(LRDFN,"AW")) D
+ . D LINE,LN
+ . S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(20,CCNT,"No organ weights entered.")
+ . D LINE
+ I $D(^LR(LRDFN,"AW")) S X=^("AW") D
+ . S B(9)=$P(X,"^",9),B(1)=$P(X,"^",11,99)
+ . D LINE,LN
+ . S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,"Rt--Lung--Lt  Liver Spleen  RT--Kidney--Lt  Brain  Body Wt(lb)    Ht(in)")
+ I $D(B) D
+ . D LN
+ . S OUT=$$S^LR7OS(XPOS,CCNT,$J($P(X,"^",3),4))_$$S^LR7OS(9,CCNT,$J($P(X,"^",4),4))_$$S^LR7OS(15,CCNT,$J($P(X,"^",5),5))_$$S^LR7OS(22,CCNT,$J($P(X,"^",6),5))_$$S^LR7OS(29,CCNT,$J($P(X,"^",7),4))_$$S^LR7OS(39,CCNT,$J($P(X,"^",8),4))
+ . S OUT=OUT_$$S^LR7OS(45,CCNT,$J($P(X,"^",10),4))_$$S^LR7OS(55,CCNT,$P(X,"^",2))_$$S^LR7OS(68,CCNT,$P(X,"^"))
+ . S ^TMP("LRC",$J,GCNT,0)=OUT
+ D LINE,LN
+ S ^TMP("LRC",$J,GCNT,0)=""
+ I $D(B) S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,"Heart(gm)")
+ I $D(^LR(LRDFN,"AV")) S X=^("AV"),B(2)=$P(X,"^",7,99),^(0)=^TMP("LRC",$J,GCNT,0)_$$S^LR7OS(12,CCNT,"TV(cm)  PV(cm)  MV(cm)  AV(cm)  RV(cm)  LV(cm)")
+ D LN
+ S ^TMP("LRC",$J,GCNT,0)=""
+ I $D(B(9)) S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,$J(B(9),5))
+ I $D(B(2)) D
+ . S OUT=$$S^LR7OS(12,CCNT,$J($P(X,"^"),4))_$$S^LR7OS(20,CCNT,$J($P(X,"^",2),4))_$$S^LR7OS(28,CCNT,$J($P(X,"^",3),4))_$$S^LR7OS(36,CCNT,$J($P(X,"^",4),4))_$$S^LR7OS(44,CCNT,$J($P(X,"^",5),4))_$$S^LR7OS(52,CCNT,$J($P(X,"^",6),4))
+ . S ^(0)=^TMP("LRC",$J,GCNT,0)_OUT
+ . D LINE,LN
+ . S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,"Cavities(ml): Rt--Pleural--Lt  Pericardial  Peritoneal")
+ . D LN
+ . S OUT=$$S^LR7OS(14,CCNT,$J($P(B(2),"^",2),4))_$$S^LR7OS(25,CCNT,$J($P(B(2),"^"),4))_$$S^LR7OS(33,CCNT,$J($P(B(2),"^",3),4))_$$S^LR7OS(45,CCNT,$J($P(B(2),"^",4),4))
+ . S ^TMP("LRC",$J,GCNT,0)=OUT
+ I $D(B(1)) F B=1:1:8 D
+ . I $P(B(1),"^",B) D
+ .. S X="25."_B
+ .. D LN
+ .. S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,$P(^DD(63,X,0),"^")_": "_$P(B(1),"^",B))
+ I $D(^LR(LRDFN,"AWI")) S Y=^("AWI") F B=1:1:5 I $P(Y,"^",B) D LN S X=$S(B=1:25.9,1:25.9_(B-1)),^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,$P(^DD(63,X,0),"^")_": "_$P(Y,"^",B))
+ Q
+ZZ ;;
+ D LN
+ N OUT,X,LRLLOC,DA,A,B,C,LR,Y
+ S OUT=$$S^LR7OS(XPOS,CCNT,"Acc #")_$$S^LR7OS(9,CCNT,"Date/time Died")_$$S^LR7OS(27,CCNT,"Age")_$$S^LR7OS(33,CCNT,"AUTOPSY DATA")_$$S^LR7OS(53,CCNT,"Date/time of Autopsy"),^TMP("LRC",$J,GCNT,0)=OUT
+ S X=^LR(LRDFN,"AU"),LRLLOC=$P(X,"^",8),DA=LRDFN
+ D D^LRAUAW
+ S Y=LR(63,12)
+ D D^LRU,LN
+ S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,($P(X,"^",6)_" "_Y))_$$S^LR7OS(26,CCNT,$J($P(X,"^",9),3))_$$S^LR7OS(33,CCNT,PNM)
+ S Y=+X
+ D D^LRU
+ I Y'[1700 S ^(0)=^TMP("LRC",$J,GCNT,0)_$$S^LR7OS(53,CCNT,Y)
+ D LN
+ S ^TMP("LRC",$J,GCNT,0)=""
+ F X(1)=7,10 D
+ . S Y=$P(X,"^",X(1)),Y=$S(Y="":Y,$D(^VA(200,Y,0)):$P(^(0),"^"),1:Y)
+ . I Y]"" S ^TMP("LRC",$J,GCNT,0)=^TMP("LRC",$J,GCNT,0)_$S(X(1)=7:$$S^LR7OS(1,CCNT,"Resident: ")_Y,1:$$S^LR7OS(38,CCNT,"Senior: ")_Y)
+ Q
+LRAPT3 ;COPIED FROM ^LRAPT3
+ ;;
+ N A,C,X,T,F
+ S (F,A)=0
+ F  S A=$O(^LR(LRDFN,"AY",A)) Q:'A  D
+ .I $D(^LR(LRDFN,"AY",A,0)) S T=+^(0) D
+ ..S T(1)=$P($G(^LAB(61,T,0)),"^")
+ ..S C=0 F  S C=$O(^LR(LRDFN,"AY",A,5,C)) Q:'C  D
+ ...S X=^LR(LRDFN,"AY",A,5,C,0) D SP(X) S F=1
+ ;Removed code that prints ICD codes per LR*5.2*259
+ Q
+SP(NODE) ;
+ N Y,E,X,A1,B
+ S Y=$P(NODE,"^",2),E=$P(NODE,"^",3),X=$P(NODE,"^")_":",A1=$P($P(LRAU("S"),X,2),";",1)
+ D D^LRU
+ S T(2)=Y
+ I 'F D LINE,LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,T(1))
+ D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,A1_" "_E_" Date: "_T(2))
+ D WRAP^LR7OSAP1("^LR("_LRDFN_",""AY"","_A_",5,"_C_",1)",80)
+ Q
+OUT ;Show output
+ Q:'$D(^TMP("LRC",$J))
+ N I
+ S I=0
+ F  S I=$O(^TMP("LRC",$J,I)) Q:'I  W !,^(I,0)
+ Q

WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRAPBR1.m

-              r613
+              r623
+LRAPBR1 ;DALOI/WTY/KLL;AP Browser Print Cont.;11/08/01
+        ;;5.2;LAB SERVICE;**259,317,363**;Sep 27, 1994;Build 3
+        ;
+        ;
+ENTER   ;from LRAPBR
+        N LRCNT,LRTMP,LRA1,LRADESC,LRLENG1,LRLENG2,LRFILE,LRAPMD
+        N LRFLD,LRV,LRV1,LRV2,LRB1,LRTEXT,LRSPCE,LRIENS,LRAPMR
+        Q:'$D(^LR(LRDFN,LRSS,LRI,0))
+        S:'LRTIU GROOT="^TMP(""LRAPBR"",$J,"
+        S:LRTIU GROOT="^TMP(""TIUP"",$J,"
+        D INP^VADPT S LRPRAC=+VAIN(2)
+        S:'LRPRAC LRPRAC(1)=""
+        I LRPRAC S X=LRPRAC D D^LRUA S LRPRAC(1)=X
+        S LRQ=0 D ^LRUA,HEADER
+        S LR("F")=1
+        D DASH
+        D:LRTIU GLENTRY("$TEXT",,1)
+        D GLENTRY("Submitted by: "_LRW(5),"",1)
+        D GLENTRY("Date obtained: "_LRTK,44)
+        D:LRA DASH
+MAIN    ;
+        D SPEC
+        D MODCHK
+        D SUPBNNR
+        D DIAG
+        D DOC
+        D WPFLD
+        D SUPRPT
+        D SSJR
+        Q
+SPEC    ;List specimens
+        D GLENTRY("Specimen (Received "_LRTK(1)_"):","",1)
+        S LRCNT=$P(^LR(LRDFN,LRSS,LRI,.1,0),U,4)
+        Q:'LRCNT
+        S LRFILE=+$$GET1^DID(LRSF,.012,"","SPECIFIER")
+        S LRIENS=LRI_","_LRDFN_","
+        S LRCT2=0
+        F LRB1=1:1 D  Q:LRCT2=LRCNT
+        .D GETS^DIQ(LRFILE,LRB1_","_LRIENS,.01,"","LRTMP("_LRB1_")")
+        .I $D(LRTMP(LRB1)) S LRCT2=LRCT2+1
+        S LRA1=0 F  S LRA1=$O(LRTMP(LRA1)) Q:'LRA1  D
+        .S LRTEXT=LRTMP(LRA1,LRFILE,LRA1_","_LRIENS,.01)
+        .D GLENTRY(LRTEXT,"",1)
+        Q
+MODCHK  ;Display modified banner if required
+        S LRAPMR=$$GET1^DIQ(LRSF,LRIENS,.17,"I")
+        Q:'LRAPMR
+        S LRAPMD=$$GET1^DIQ(LRSF,LRIENS,.172,"I")
+        D GLENTRY("","",1)
+        S LRTEXT=""
+        F LRCNT=1:1:$S(LRAPMD:14,1:15) D
+        .S LRTEXT=LRTEXT_"*+"
+        S LRTEXT=LRTEXT_" MODIFIED "
+        S LRTEXT=LRTEXT_$S(LRAPMD:"DIAGNOSIS ",1:"REPORT ")
+        F LRCNT=1:1:$S(LRAPMD:14,1:15) D
+        .S LRTEXT=LRTEXT_"*+"
+        D GLENTRY(LRTEXT,"",1)
+        D GLENTRY("","",1)
+        Q
+SUPBNNR ;Display supplementary report header if one or more has been added
+        I $P($G(^LR(LRDFN,LRSS,LRI,1.2,0)),U,4) D
+        .S LRTEXT="*+* SUPPLEMENTARY REPORT HAS BEEN ADDED *+*"
+        .D GLENTRY($$CJ^XLFSTR(LRTEXT,IOM),"",1)
+        .S LRTEXT="*+* REFER TO BOTTOM OF REPORT *+*"
+        .D GLENTRY($$CJ^XLFSTR(LRTEXT,IOM),"",1)
+        .D GLENTRY("","",1)
+        Q
+DIAG    ;
+        ;Display the Brief Clinical History, Preoperative Diagnosis,
+        ;Operative Findings, and Postoperative Diagnosis
+        S LRFILE=LRSF,LRCNT=0,LRIENS=LRI_","_LRDFN_","
+        F LRFLD=.013:.001:.016 D
+        .D:LRA DASH
+        .S LRCNT=LRCNT+1
+        .D GLENTRY($P($T(TEXT1+LRCNT),";",2),"",1)
+        .D WP
+        Q
+DOC     ;
+        ;Pathologist information
+        D GLENTRY("","",1)
+        D GLENTRY("Surgeon/physician: "_LRMD,27,1)
+        D:LRA GLENTRY(LR("%1"),"",1)
+        D DASH
+        D HEADER2
+        D:LRA DASH
+        I LRRC="" D
+        .D GLENTRY("+*+* REPORT INCOMPLETE *+*+",20,1)
+        .D GLENTRY("","",1)
+        D GLENTRY("","",1)
+        I LRRMD'="" D
+        .S LRCNT=0 F LRA1="SP","CY","EM" D
+        ..S LRCNT=LRCNT+1
+        ..S LRTMP(LRA1)=$P($T(TEXT2+LRCNT),";",3)
+        .S LRTMP=LRTMP(LRSS)
+        .D GLENTRY(LRTMP_" "_LRRMD,31)
+        Q
+WPFLD   ;
+        ;Display Frozen Section, Gross Description, Microscopic Description
+        ;and Surgical Path Diagnosis
+        F LRCNT=1:1:4 D
+        .S X=$T(FIELDS+LRCNT)
+        .S LRV=$P(X,";",2),LRV1=$P(X,";",3),LRV2=$P(X,";",4)
+        .D TEXTCHK
+        .I $P($G(^LR(LRDFN,LRSS,LRI,LRV,0)),U,4) D
+        ..D GLENTRY("","",1),GLENTRY(LR(69.2,LRV1),"",1)
+        ..S LRFILE=LRSF,LRIENS=LRI_","_LRDFN_",",LRFLD=LRV
+        ..I $P($G(^LR(LRDFN,LRSS,LRI,LRV2,0)),U,4) D
+        ...S LRFILE1=+$$GET1^DID(LRSF,LRV2,"","SPECIFIER")
+        ...D GLENTRY("*+* MODIFIED REPORT *+*",28,1)
+        ...D GLENTRY("(Last modified: ","",1)
+        ...S (LRA1,LRB1)=0
+        ...F  S LRA1=$O(^LR(LRDFN,LRSS,LRI,LRV2,LRA1)) Q:'LRA1  S LRB1=LRA1
+        ...Q:'$D(^LR(LRDFN,LRSS,LRI,LRV2,LRB1,0))
+        ...S LRSR1=$$GET1^DIQ(LRFILE1,LRB1_","_LRIENS,.01)
+        ...S LRSR2=$$GET1^DIQ(LRFILE1,LRB1_","_LRIENS,.02)
+        ...S LRTEXT=LRSR1_" typed by "_LRSR2_")"
+        ...D GLENTRY(LRTEXT,BTAB)
+        ..D WP
+        Q
+SUPRPT  ;Supplementary Report
+        I $P($G(^LR(LRDFN,LRSS,LRI,1.2,0)),U,4) D
+        .S LRFILE=+$$GET1^DID(LRSF,1.2,"","SPECIFIER")
+        .S LRIENS1=LRI_","_LRDFN_","
+        .D GLENTRY("","",1),GLENTRY("SUPPLEMENTARY REPORT(S):","",1)
+        .S LRV=0 F  S LRV=$O(^LR(LRDFN,LRSS,LRI,1.2,LRV)) Q:'LRV  D
+        ..S LRIENS=LRV_","_LRIENS1
+        ..S LRSR1=$$GET1^DIQ(LRFILE,LRIENS,.01)
+        ..S LRSR2=+$$GET1^DIQ(LRFILE,LRIENS,.02)
+        ..D GLENTRY("Supplementary Report Date: "_LRSR1,3,1)
+        ..I $D(LR("R")),'LRSR2 D GLENTRY(" not verified",BTAB) Q
+        ..I $P($G(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,0)),U,4) D
+        ...S LRTEXT="*+* SUPPLEMENTARY REPORT HAS BEEN ADDED/MODIFIED *+*"
+        ...D GLENTRY($$CJ^XLFSTR(LRTEXT,IOM),"",1)
+        ...D GLENTRY("(Added/Last","",1)
+        ...S (LRA1,LRB1)=0
+        ...F  S LRA1=$O(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,LRA1)) Q:'LRA1  D
+        ....S LRB1=LRA1
+        ...Q:'$D(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,LRB1,0))
+        ...S LRA2=^(0),Y=+LRA2,LRA2A=$P(LRA2,"^",2),LRSGN=" Typed by ",LRDSC=" modified: "
+        ...I $P(LRA2,"^",3) S LRSGN=" Signed by ",LRDSC=" released: ",LRA2A=$P(LRA2,"^",3),Y=$P(LRA2,"^",4)
+        ...S LRA2A=$S($D(^VA(200,LRA2A,0)):$P(^(0),"^"),1:LRA2A)
+        ...D D^LRU
+        ...D GLENTRY(LRDSC_Y_LRSGN_LRA2A_")",BTAB)
+        ..S LRFLD=1 D WP
+        ..D GLENTRY("","",1)
+        Q
+SSJR    ;Print special studies/journal references
+        D ^LRAPBR3
+        S LREFLG=1
+        Q
+WP      ;Display word procesing fields
+        K LRTMP,^UTILITY($J,"W")
+        N X,DIWR,DIWL,LRINC
+        S X=$$GET1^DIQ(LRFILE,LRIENS,LRFLD,"","LRTMP",)
+        S DIWR=IOM-5,DIWL=5,DIWF=""
+        S X=+$$GET1^DID(LRFILE,LRFLD,"","SPECIFIER")
+        I $$GET1^DID(X,.01,"","SPECIFIER")["L" S DIWF="N"
+        S LRINC=0
+        F  S LRINC=$O(LRTMP(LRINC)) Q:'LRINC  S X=LRTMP(LRINC) D ^DIWP
+        S LRINC=0
+        F  S LRINC=$O(^UTILITY($J,"W",DIWL,LRINC)) Q:'LRINC  D
+        .D GLENTRY(^UTILITY($J,"W",DIWL,LRINC,0),DIWL,1)
+        K ^UTILITY($J,"W")
+        Q
+HEADER  ;
+        D:LRTIU GLENTRY("$APHDR",,1)
+        D GLENTRY("","",1)
+        D DASH
+        D GLENTRY("MEDICAL RECORD |",5,1)
+        D GLENTRY(LRAA1,40)
+        D DASH
+HEADER2 ;
+        S LRADESC="Accession No. "_$S(LRQ(8)]"":LRQ(8)_LRW(1)_" "_LRAC,1:LRAC)
+        S LRLENG1=$L(LRQ(1)),LRLENG2=$L(LRADESC),LRSPCE=IOM-LRLENG2-14
+        S:LRLENG1>LRSPCE LRQ(1)=$E(LRQ(1),1,LRSPCE)
+        D GLENTRY("PATHOLOGY REPORT",30,1)
+        D GLENTRY("Laboratory: "_LRQ(1),"",1)
+        D GLENTRY(LRADESC,IOM-LRLENG2-1)
+        Q
+FOOTER  ;Footer-called from ^LRAPBR
+        D:LRTIU GLENTRY("$FTR",,1)
+        D DASH
+        S LRTEXT=$S('$D(LR("W")):"",1:"See signed copy in chart")
+        D GLENTRY(LRTEXT,"",1)
+        S LRTEXT="("_$S($D(LREFLG):"End of report",1:"See next page")_")"
+        D GLENTRY(LRTEXT,57)
+        D GLENTRY(LRPMD,"",1),GLENTRY(LRW(9),52),GLENTRY("| Date "_LRRC,55)
+        D DASH
+        D GLENTRY(LRP,"",1)
+        S LRTEXT=$S('$D(LR("W")):"STANDARD FORM 515",1:"WORK COPY ONLY !!")
+        D GLENTRY(LRTEXT,50)
+        D GLENTRY("ID:"_SSN,"",1)
+        D GLENTRY("SEX:"_SEX,16),GLENTRY(" DOB:"_DOB,BTAB)
+        I AGE D
+        .S LRTEXT=$S($G(VADM(6))]"":" AGE AT DEATH: ",1:" AGE: ")_AGE
+        .D GLENTRY(LRTEXT,BTAB)
+        D GLENTRY(" LOC:"_LRLLOC,BTAB)
+        D GLENTRY("","",1)
+        D:$L(LRADM) GLENTRY("ADM:"_$P(LRADM,"@"),BTAB)
+        D:$L(LRADX) GLENTRY("DX:"_$E(LRADX,1,26),17)
+        D GLENTRY("PCP:",46)
+        D:$L(LRPRAC) GLENTRY($E(LRPRAC(1),1,28),51)
+        Q
+ESIGLN  ;Write signature block name, title, and date of signature
+        D GLENTRY(,,1)
+        I $D(^VA(200,DUZ,0)) D
+        .S LRFILE=200,LRFLD=20.2,LRFLD2=20.3
+        .S X=$$GET1^DIQ(LRFILE,DUZ,LRFLD)
+        ;Compare DUZ to pathologist, if different, use proxy signature
+        S:LRSS="AU" LRPATH=$$GET1^DIQ(63,LRDFN,13.6,"I")
+        I LRSS'="AU" D
+        .S LRFL2=$S(LRSS="EM":63.02,LRSS="CY":63.09,LRSS="SP":63.08,1:0)
+        .S LRIENS=LRI_","_LRDFN_","
+        .S LRPATH=$$GET1^DIQ(LRFL2,LRIENS,.02,"I")
+        S LRPATH2=""
+        S:LRPATH'=DUZ LRPATH2=" FOR "_$$GET1^DIQ(LRFILE,LRPATH,LRFLD)
+        S LRTEXT="/es/ "_X_LRPATH2
+        ;S LRTEXT="/es/ "_X
+        D GLENTRY(LRTEXT,,1)
+        S X=$$GET1^DIQ(LRFILE,DUZ,LRFLD2)
+        S LRTEXT=X
+        D GLENTRY(LRTEXT,,1)
+        S Y=LRNTIME D DD^%DT
+        S LRTEXT="Signed "_Y
+        D GLENTRY(LRTEXT,,1)
+        Q
+DASH    ;Display a line of dashes
+        D GLENTRY(LR("%"),"",1)
+        Q
+GLENTRY(LRPR1,LRPR2,LRPR3)      ;Write to global
+        ;LRPR1 = Text to be written to global
+        ;LRPR2 = Tab position
+        ;LRPR3 = 1 means start a new line.  Othewise, write an current line.
+        S LRPR1=$G(LRPR1)
+        S LRPR2=+$G(LRPR2)
+        S LRPR3=+$G(LRPR3)
+        D:LRPR3 NEWLN^LRAPUTL(LRPR1,LRPR2)
+        D:'LRPR3 GLBWRT^LRAPUTL(LRPR1,LRPR2)
+        Q
+TEXT1   ;Text for top of report
+        ;BRIEF CLINICAL HISTORY:
+        ;PREOPERATIVE DIAGNOSIS:
+        ;OPERATIVE FINDINGS:
+        ;POSTOPERATIVE DIAGNOSIS:
+TEXT2   ;Descriptive text based on section
+        ;SP;Pathology Resident:
+        ;CY;Screened by:
+        ;EM;Prepared by:
+FIELDS  ;Field numbers for word processing fields
+        ;1.3;.13;6
+        ;1;.03;7
+        ;1.1;.04;4
+        ;1.4;.14;5
+TEXTCHK ; update text line counter if it is missing (Remedy 116253)
+        N I,X,DATA
+        S I=0
+        K ^TMP("WP",$J)
+        S X=$G(^LR(LRDFN,LRSS,LRI,LRV,0))
+        I X'="",$L(X,"^")=1 D
+        . F  S I=$O(^LR(LRDFN,LRSS,LRI,LRV,I)) Q:I=""  D
+        . . S DATA=$G(^LR(LRDFN,LRSS,LRI,LRV,I,0))
+        . . S ^TMP("WP",$J,I,0)=DATA
+        I $D(^TMP("WP",$J)) D
+        . D WP^DIE(63.08,LRI_","_LRDFN_",",LRV,"","^TMP(""WP"",$J)")
+        . K ^TMP("WP",$J)
+        Q
+LRAPBR1 ;DALOI/WTY/KLL;AP Browser Print Cont.;11/08/01
+ ;;5.2;LAB SERVICE;**259,317**;Sep 27, 1994
+ ;
+ ;
+ENTER ;from LRAPBR
+ N LRCNT,LRTMP,LRA1,LRADESC,LRLENG1,LRLENG2,LRFILE,LRAPMD
+ N LRFLD,LRV,LRV1,LRV2,LRB1,LRTEXT,LRSPCE,LRIENS,LRAPMR
+ Q:'$D(^LR(LRDFN,LRSS,LRI,0))
+ S:'LRTIU GROOT="^TMP(""LRAPBR"",$J,"
+ S:LRTIU GROOT="^TMP(""TIUP"",$J,"
+ D INP^VADPT S LRPRAC=+VAIN(2)
+ S:'LRPRAC LRPRAC(1)=""
+ I LRPRAC S X=LRPRAC D D^LRUA S LRPRAC(1)=X
+ S LRQ=0 D ^LRUA,HEADER
+ S LR("F")=1
+ D DASH
+ D:LRTIU GLENTRY("$TEXT",,1)
+ D GLENTRY("Submitted by: "_LRW(5),"",1)
+ D GLENTRY("Date obtained: "_LRTK,44)
+ D:LRA DASH
+MAIN ;
+ D SPEC
+ D MODCHK
+ D SUPBNNR
+ D DIAG
+ D DOC
+ D WPFLD
+ D SUPRPT
+ D SSJR
+ Q
+SPEC ;List specimens
+ D GLENTRY("Specimen (Received "_LRTK(1)_"):","",1)
+ S LRCNT=$P(^LR(LRDFN,LRSS,LRI,.1,0),U,4)
+ Q:'LRCNT
+ S LRFILE=+$$GET1^DID(LRSF,.012,"","SPECIFIER")
+ S LRIENS=LRI_","_LRDFN_","
+ S LRCT2=0
+ F LRB1=1:1 D  Q:LRCT2=LRCNT
+ .D GETS^DIQ(LRFILE,LRB1_","_LRIENS,.01,"","LRTMP("_LRB1_")")
+ .I $D(LRTMP(LRB1)) S LRCT2=LRCT2+1
+ S LRA1=0 F  S LRA1=$O(LRTMP(LRA1)) Q:'LRA1  D
+ .S LRTEXT=LRTMP(LRA1,LRFILE,LRA1_","_LRIENS,.01)
+ .D GLENTRY(LRTEXT,"",1)
+ Q
+MODCHK ;Display modified banner if required
+ S LRAPMR=$$GET1^DIQ(LRSF,LRIENS,.17,"I")
+ Q:'LRAPMR
+ S LRAPMD=$$GET1^DIQ(LRSF,LRIENS,.172,"I")
+ D GLENTRY("","",1)
+ S LRTEXT=""
+ F LRCNT=1:1:$S(LRAPMD:14,1:15) D
+ .S LRTEXT=LRTEXT_"*+"
+ S LRTEXT=LRTEXT_" MODIFIED "
+ S LRTEXT=LRTEXT_$S(LRAPMD:"DIAGNOSIS ",1:"REPORT ")
+ F LRCNT=1:1:$S(LRAPMD:14,1:15) D
+ .S LRTEXT=LRTEXT_"*+"
+ D GLENTRY(LRTEXT,"",1)
+ D GLENTRY("","",1)
+ Q
+SUPBNNR ;Display supplementary report header if one or more has been added
+ I $P($G(^LR(LRDFN,LRSS,LRI,1.2,0)),U,4) D
+ .S LRTEXT="*+* SUPPLEMENTARY REPORT HAS BEEN ADDED *+*"
+ .D GLENTRY($$CJ^XLFSTR(LRTEXT,IOM),"",1)
+ .S LRTEXT="*+* REFER TO BOTTOM OF REPORT *+*"
+ .D GLENTRY($$CJ^XLFSTR(LRTEXT,IOM),"",1)
+ .D GLENTRY("","",1)
+ Q
+DIAG ;
+ ;Display the Brief Clinical History, Preoperative Diagnosis,
+ ;Operative Findings, and Postoperative Diagnosis
+ S LRFILE=LRSF,LRCNT=0,LRIENS=LRI_","_LRDFN_","
+ F LRFLD=.013:.001:.016 D
+ .D:LRA DASH
+ .S LRCNT=LRCNT+1
+ .D GLENTRY($P($T(TEXT1+LRCNT),";",2),"",1)
+ .D WP
+ Q
+DOC ;
+ ;Pathologist information
+ D GLENTRY("","",1)
+ D GLENTRY("Surgeon/physician: "_LRMD,27,1)
+ D:LRA GLENTRY(LR("%1"),"",1)
+ D DASH
+ D HEADER2
+ D:LRA DASH
+ I LRRC="" D
+ .D GLENTRY("+*+* REPORT INCOMPLETE *+*+",20,1)
+ .D GLENTRY("","",1)
+ D GLENTRY("","",1)
+ I LRRMD'="" D
+ .S LRCNT=0 F LRA1="SP","CY","EM" D
+ ..S LRCNT=LRCNT+1
+ ..S LRTMP(LRA1)=$P($T(TEXT2+LRCNT),";",3)
+ .S LRTMP=LRTMP(LRSS)
+ .D GLENTRY(LRTMP_" "_LRRMD,31)
+ Q
+WPFLD ;
+ ;Display Frozen Section, Gross Description, Microscopic Description
+ ;and Surgical Path Diagnosis
+ F LRCNT=1:1:4 D
+ .S X=$T(FIELDS+LRCNT)
+ .S LRV=$P(X,";",2),LRV1=$P(X,";",3),LRV2=$P(X,";",4)
+ .I $P($G(^LR(LRDFN,LRSS,LRI,LRV,0)),U,4) D
+ ..D GLENTRY("","",1),GLENTRY(LR(69.2,LRV1),"",1)
+ ..S LRFILE=LRSF,LRIENS=LRI_","_LRDFN_",",LRFLD=LRV
+ ..I $P($G(^LR(LRDFN,LRSS,LRI,LRV2,0)),U,4) D
+ ...S LRFILE1=+$$GET1^DID(LRSF,LRV2,"","SPECIFIER")
+ ...D GLENTRY("*+* MODIFIED REPORT *+*",28,1)
+ ...D GLENTRY("(Last modified: ","",1)
+ ...S (LRA1,LRB1)=0
+ ...F  S LRA1=$O(^LR(LRDFN,LRSS,LRI,LRV2,LRA1)) Q:'LRA1  S LRB1=LRA1
+ ...Q:'$D(^LR(LRDFN,LRSS,LRI,LRV2,LRB1,0))
+ ...S LRSR1=$$GET1^DIQ(LRFILE1,LRB1_","_LRIENS,.01)
+ ...S LRSR2=$$GET1^DIQ(LRFILE1,LRB1_","_LRIENS,.02)
+ ...S LRTEXT=LRSR1_" typed by "_LRSR2_")"
+ ...D GLENTRY(LRTEXT,BTAB)
+ ..D WP
+ Q
+SUPRPT ;Supplementary Report
+ I $P($G(^LR(LRDFN,LRSS,LRI,1.2,0)),U,4) D
+ .S LRFILE=+$$GET1^DID(LRSF,1.2,"","SPECIFIER")
+ .S LRIENS1=LRI_","_LRDFN_","
+ .D GLENTRY("","",1),GLENTRY("SUPPLEMENTARY REPORT(S):","",1)
+ .S LRV=0 F  S LRV=$O(^LR(LRDFN,LRSS,LRI,1.2,LRV)) Q:'LRV  D
+ ..S LRIENS=LRV_","_LRIENS1
+ ..S LRSR1=$$GET1^DIQ(LRFILE,LRIENS,.01)
+ ..S LRSR2=+$$GET1^DIQ(LRFILE,LRIENS,.02)
+ ..D GLENTRY("Supplementary Report Date: "_LRSR1,3,1)
+ ..I $D(LR("R")),'LRSR2 D GLENTRY(" not verified",BTAB) Q
+ ..I $P($G(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,0)),U,4) D
+ ...S LRTEXT="*+* SUPPLEMENTARY REPORT HAS BEEN ADDED/MODIFIED *+*"
+ ...D GLENTRY($$CJ^XLFSTR(LRTEXT,IOM),"",1)
+ ...D GLENTRY("(Added/Last","",1)
+ ...S (LRA1,LRB1)=0
+ ...F  S LRA1=$O(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,LRA1)) Q:'LRA1  D
+ ....S LRB1=LRA1
+ ...Q:'$D(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,LRB1,0))
+ ...S LRA2=^(0),Y=+LRA2,LRA2A=$P(LRA2,"^",2),LRSGN=" Typed by ",LRDSC=" modified: "
+ ...I $P(LRA2,"^",3) S LRSGN=" Signed by ",LRDSC=" released: ",LRA2A=$P(LRA2,"^",3),Y=$P(LRA2,"^",4)
+ ...S LRA2A=$S($D(^VA(200,LRA2A,0)):$P(^(0),"^"),1:LRA2A)
+ ...D D^LRU
+ ...D GLENTRY(LRDSC_Y_LRSGN_LRA2A_")",BTAB)
+ ..S LRFLD=1 D WP
+ ..D GLENTRY("","",1)
+ Q
+SSJR ;Print special studies/journal references
+ D ^LRAPBR3
+ S LREFLG=1
+ Q
+WP ;Display word procesing fields
+ K LRTMP,^UTILITY($J,"W")
+ N X,DIWR,DIWL,LRINC
+ S X=$$GET1^DIQ(LRFILE,LRIENS,LRFLD,"","LRTMP",)
+ S DIWR=IOM-5,DIWL=5,DIWF=""
+ S X=+$$GET1^DID(LRFILE,LRFLD,"","SPECIFIER")
+ I $$GET1^DID(X,.01,"","SPECIFIER")["L" S DIWF="N"
+ S LRINC=0
+ F  S LRINC=$O(LRTMP(LRINC)) Q:'LRINC  S X=LRTMP(LRINC) D ^DIWP
+ S LRINC=0
+ F  S LRINC=$O(^UTILITY($J,"W",DIWL,LRINC)) Q:'LRINC  D
+ .D GLENTRY(^UTILITY($J,"W",DIWL,LRINC,0),DIWL,1)
+ K ^UTILITY($J,"W")
+ Q
+HEADER ;
+ D:LRTIU GLENTRY("$APHDR",,1)
+ D GLENTRY("","",1)
+ D DASH
+ D GLENTRY("MEDICAL RECORD |",5,1)
+ D GLENTRY(LRAA1,40)
+ D DASH
+HEADER2 ;
+ S LRADESC="Accession No. "_$S(LRQ(8)]"":LRQ(8)_LRW(1)_" "_LRAC,1:LRAC)
+ S LRLENG1=$L(LRQ(1)),LRLENG2=$L(LRADESC),LRSPCE=IOM-LRLENG2-14
+ S:LRLENG1>LRSPCE LRQ(1)=$E(LRQ(1),1,LRSPCE)
+ D GLENTRY("PATHOLOGY REPORT",30,1)
+ D GLENTRY("Laboratory: "_LRQ(1),"",1)
+ D GLENTRY(LRADESC,IOM-LRLENG2-1)
+ Q
+FOOTER ;Footer-called from ^LRAPBR
+ D:LRTIU GLENTRY("$FTR",,1)
+ D DASH
+ S LRTEXT=$S('$D(LR("W")):"",1:"See signed copy in chart")
+ D GLENTRY(LRTEXT,"",1)
+ S LRTEXT="("_$S($D(LREFLG):"End of report",1:"See next page")_")"
+ D GLENTRY(LRTEXT,57)
+ D GLENTRY(LRPMD,"",1),GLENTRY(LRW(9),52),GLENTRY("| Date "_LRRC,55)
+ D DASH
+ D GLENTRY(LRP,"",1)
+ S LRTEXT=$S('$D(LR("W")):"STANDARD FORM 515",1:"WORK COPY ONLY !!")
+ D GLENTRY(LRTEXT,50)
+ D GLENTRY("ID:"_SSN,"",1)
+ D GLENTRY("SEX:"_SEX,16),GLENTRY(" DOB:"_DOB,BTAB)
+ I AGE D
+ .S LRTEXT=$S($G(VADM(6))]"":" AGE AT DEATH: ",1:" AGE: ")_AGE
+ .D GLENTRY(LRTEXT,BTAB)
+ D GLENTRY(" LOC:"_LRLLOC,BTAB)
+ D GLENTRY("","",1)
+ D:$L(LRADM) GLENTRY("ADM:"_$P(LRADM,"@"),BTAB)
+ D:$L(LRADX) GLENTRY("DX:"_$E(LRADX,1,26),17)
+ D GLENTRY("PCP:",46)
+ D:$L(LRPRAC) GLENTRY($E(LRPRAC(1),1,28),51)
+ Q
+ESIGLN ;Write signature block name, title, and date of signature
+ D GLENTRY(,,1)
+ I $D(^VA(200,DUZ,0)) D
+ .S LRFILE=200,LRFLD=20.2,LRFLD2=20.3
+ .S X=$$GET1^DIQ(LRFILE,DUZ,LRFLD)
+ ;Compare DUZ to pathologist, if different, use proxy signature
+ S:LRSS="AU" LRPATH=$$GET1^DIQ(63,LRDFN,13.6,"I")
+ I LRSS'="AU" D
+ .S LRFL2=$S(LRSS="EM":63.02,LRSS="CY":63.09,LRSS="SP":63.08,1:0)
+ .S LRIENS=LRI_","_LRDFN_","
+ .S LRPATH=$$GET1^DIQ(LRFL2,LRIENS,.02,"I")
+ S LRPATH2=""
+ S:LRPATH'=DUZ LRPATH2=" FOR "_$$GET1^DIQ(LRFILE,LRPATH,LRFLD)
+ S LRTEXT="/es/ "_X_LRPATH2
+ ;S LRTEXT="/es/ "_X
+ D GLENTRY(LRTEXT,,1)
+ S X=$$GET1^DIQ(LRFILE,DUZ,LRFLD2)
+ S LRTEXT=X
+ D GLENTRY(LRTEXT,,1)
+ S Y=LRNTIME D DD^%DT
+ S LRTEXT="Signed "_Y
+ D GLENTRY(LRTEXT,,1)
+ Q
+DASH ;Display a line of dashes
+ D GLENTRY(LR("%"),"",1)
+ Q
+GLENTRY(LRPR1,LRPR2,LRPR3) ;Write to global
+ ;LRPR1 = Text to be written to global
+ ;LRPR2 = Tab position
+ ;LRPR3 = 1 means start a new line.  Othewise, write an current line.
+ S LRPR1=$G(LRPR1)
+ S LRPR2=+$G(LRPR2)
+ S LRPR3=+$G(LRPR3)
+ D:LRPR3 NEWLN^LRAPUTL(LRPR1,LRPR2)
+ D:'LRPR3 GLBWRT^LRAPUTL(LRPR1,LRPR2)
+ Q
+TEXT1 ;Text for top of report
+ ;BRIEF CLINICAL HISTORY:
+ ;PREOPERATIVE DIAGNOSIS:
+ ;OPERATIVE FINDINGS:
+ ;POSTOPERATIVE DIAGNOSIS:
+TEXT2 ;Descriptive text based on section
+ ;SP;Pathology Resident:
+ ;CY;Screened by:
+ ;EM;Prepared by:
+FIELDS ;Field numbers for word processing fields
+ ;1.3;.13;6
+ ;1;.03;7
+ ;1.1;.04;4
+ ;1.4;.14;5

WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRAPDA.m

-              r613
+              r623
+LRAPDA  ;DALOI/REG/WTY/KLL/CKA - ANATOMIC PATH DATA ENTRY;11/02/01
+        ;;5.2;LAB SERVICE;**72,73,91,121,248,259,295,317,365**;Sep 27, 1994;Build 9
+        ;
+        ;Reference to ^%DT supported by IA #10003
+        ;Reference to ^DIE supported by IA #10018
+        ;Reference to ^VA(200 supported by IA #10060
+        ;Reference to EN^DDIOL supported by IA #10142
+        ;
+        W !?20,LRO(68)," (",LRABV,")",!
+        S:'$D(LRSOP) LRSOP=1 S:'$D(LRD(1)) LRD(1)="0"
+        S:'$D(^LRO(69.2,LRAA,2,0)) ^(0)="^69.23A^0^0"
+SEL     K LR(1)
+        I $D(LR(2)) D  G:%<1 END S:%=1 LR(1)=1
+        .W !!,"Enter Etiology, Function, Procedure & Disease "
+        .S %=2 D YN^LRU
+AK      ;from LRAPD1
+        N CORRECT
+        S:'$D(LRSFLG) LRSFLG=""
+        W !!,"Data entry for ",LRH(0)," "
+        S %=1 D YN^LRU G:%<1 END
+        I %=2 D  G:Y<1 END S LRAD=$E(Y,1,3)_"0000",LRH(0)=$E(Y,1,3)+1700
+        .S %DT="AE",%DT(0)="-N",%DT("A")="Enter YEAR: " D ^%DT K %DT
+        I '$O(^LRO(68,LRAA,1,LRAD,1,0)) D  Q
+        .W $C(7),!!,"NO ",LRO(68)," ACCESSIONS IN FILE FOR ",LRH(0),!!
+W       K X,Y,LR("CK")
+        R !!,"Select Accession Number/Pt name: ",LRAN:DTIME
+        G:LRAN=""!(LRAN[U) END
+        I LRAN["?" D  G W
+        .W !!,"Enter the year ",LRH(0)," ",LRO(68)," accession number to be "
+        .W "updated"
+        .W !,"or locate the accession by entering the patient name."
+        I LRAN'?1N.N D PNAME G:LRAN<1 W D OE1^LR7OB63D,REST,OERR^LR7OB63D G W
+        D OE1^LR7OB63D,REST S:$D(DR(1))#2 DR=DR(1) D OERR^LR7OB63D G W
+REST    ;
+        N LRXSTOP,LRX,LRX1
+        W "  for ",LRH(0)
+        I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D  Q
+        .W $C(7),!!,"Accession # ",LRAN," for ",LRH(0)," not in ",LRO(68),!!
+        S X=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRLLOC=$P(X,"^",7),LRDFN=+X
+        Q:'$D(^LR(LRDFN,0))  S X=^(0) D ^LRUP
+        W !,LRP,"  ID: ",SSN
+        S LRI=+$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5)
+        I LRSS'="AU",'$D(^LR(LRDFN,LRSS,LRI,0)) D  Q
+        .W $C(7),!,"Inverse date missing or incorrect in Accession Area file "
+        .W "for",!,LRO(68),"  Year: ",$E(LRAD,2,3),"  Accession: ",LRAN
+        I "SPCYEM"[LRSS,$O(^LR(LRDFN,LRSS,LRI,.1,0)) D
+        .W !,"Specimen(s):"
+        .S X=0 F  S X=$O(^LR(LRDFN,LRSS,LRI,.1,X)) Q:'X  D
+        ..W !,$P($G(^LR(LRDFN,LRSS,LRI,.1,X,0)),"^")
+        ;
+        ;Don't allow supp. report to be added to a released report if
+        ; modifications are being added via MM option
+        S LRXSTOP=0,(LRX,LRX1)=""
+        I LRSS'="AU",LRD(1)="S" D
+        .S LRX=$P($G(^LR(LRDFN,LRSS,LRI,0)),"^",11) ;release date/time
+        .S LRX1=$P($G(^LR(LRDFN,LRSS,LRI,0)),"^",15) ;orig rel date/time
+        I LRSS="AU",LRSOP="R" D
+        .S LRX=$P($G(^LR(LRDFN,"AU")),"^",15)  ;release date/time
+        .S LRX1=$P($G(^LR(LRDFN,"AU")),"^",3)  ;date report completed
+        I 'LRX,LRX1 D
+        .W $C(7),!!,"This "_$G(LRAA(1))_" report is currently being"
+        .W !,"modified; it must first be released before Supplementary"
+        .W !,"report can be added.",!
+        .S LRXSTOP=1
+        Q:LRXSTOP
+        ;
+DIE     ;Edit
+        I LRSS="AU" D AUE Q
+        N LRRDT1,LRRDT2,LRIENS,LREL,LRQUIT,LRSNO,LRCPT,LRESCPT
+        S (LREL,LRESCPT,LRQUIT,LRSNO,LRCPT)=0,LRIENS=LRI_","_LRDFN_","
+        S LRRDT1=$$GET1^DIQ(LRSF,LRIENS,.11,"I")
+        S LRRDT2=$$GET1^DIQ(LRSF,LRIENS,.15,"I")
+        S:LRRDT1!LRRDT2 LREL=1
+        ;Determine if CPT activated
+        I $T(ES^LRCAPES)'="" S LRESCPT=$$ES^LRCAPES()
+        I LRSOP="G",LREL D  Q
+        .W $C(7),!!,"Report verified.  Cannot edit with this option."
+        I LRSOP'="","ABM"[LRSOP,LREL D  Q:LRQUIT
+        .;Allow SNOMED and CPT coding even after release.
+        .W $C(7),!!,"Report has been verified.  "
+        .I 'LRESCPT,LRSOP'="B" D  Q
+        ..W "Cannot edit with this option."
+        ..S LRQUIT=1
+        .W "Only "
+        .I LRESCPT W "CPT " W:LRSOP="B" "and "
+        .W:LRSOP="B" "SNOMED "
+        .W "coding permitted.",!
+        .I LRSOP="B" D
+        ..K DIR S DIR(0)="Y",DIR("A")="Enter SNOMED coding",DIR("B")="NO"
+        ..D ^DIR W !
+        ..S LRSNO=+Y
+        .Q:'LRESCPT
+        .K DIR S DIR(0)="Y",DIR("A")="Enter CPT coding",DIR("B")="NO"
+        .D ^DIR W !
+        .S LRCPT=+Y
+        .I "AM"[LRSOP,'LRCPT S LRQUIT=1 Q
+        .I LRSOP="B",'LRCPT,'LRSNO S LRQUIT=1
+RESET   ;Reset DR string if altered by prior accession/patient
+        ;Reset DR to orig value in LRAPD1
+        I LRSOP'="","AMBS"[LRSOP,$G(LRD)'="" D @LRD
+        I LRSFLG="S",$G(LRD)'="" D @LRD  ;For CY,EM Supp entry
+        S:LRSNO DR=10    ;Modify DR string if only SNOMED coding permitted
+        I 'LRSNO,LRCPT S DR=""  ;Set DR string to null in only CPT coding
+        ;If adding supp rpt to released rpt, remove date rpt completed from DR
+        I LRRDT1,LRSOP="S"!(LRSFLG="S") S DR=".09///^S X=LRWHO;10"
+EDIT    ;Call to ^DIE
+        W ! S LRA=^LR(LRDFN,LRSS,LRI,0),LRRC=$P(LRA,"^",10)
+        I LRCAPA,"SPCYEM"[LRSS D C^LRAPSWK
+        S DIE="^LR(LRDFN,LRSS,",DA=LRI,DA(1)=LRDFN
+        D CK^LRU Q:$D(LR("CK"))
+        I LRSS="SP",LRSOP="B",$O(^LR(LRDFN,LRSS,LRI,1.3,0)) D
+        .W $C(7),!!,"This accession has a FROZEN SECTION report."
+        .W !,"Be sure 'FROZEN SECTION' is entered as a SNOMED code in the "
+        .W "PROCEDURE field"
+        .W !,"for the appropriate organ or tissue.",!!
+        ;Code S LRELSD is in DR string setup in LRAPR
+        N LRELSD S LRELSD=0
+        D ^DIE
+        S LRAC=$P(LRA,U,6)
+        I LRELSD D MAIN^LRAPRES1(LRDFN,LRSS,LRI,LRSF,LRP,LRAC)
+        D UPDATE^LRPXRM(LRDFN,LRSS,LRI)
+        D:LRSFLG="S"&('$D(Y)) ^LRAPDSR
+        D FRE^LRU
+        I LRSOP'="","ABM"[LRSOP D CPTCOD
+WKLD    ;Capture Workload
+        I LRSOP="Z","CYSP"[LRSS,LRCAPA D S^LRAPR Q
+        I LRCAPA,"SPCYEM"[LRSS,LRD(1)'="","MBA"[LRD(1) D C1^LRAPSWK
+        I LRCAPA,"SPCYEM"[LRSS,LRSOP="G" D C1^LRAPSWK
+QUEUES  ;Update Queues
+        S X=$P(^LR(LRDFN,LRSS,LRI,0),"^",4)
+        I X,$D(^VA(200,X,0)) S LR("TR")=$P(^(0),"^")
+        I "CYEMSP"[LRSS,$D(LR(6)),LRSOP="G" Q:$D(^LRO(69.2,LRAA,1,LRAN,0))  D  Q
+        .L +^LRO(69.2,LRAA,1):5 I '$T D  Q
+        ..S MSG(1)="The preliminary reports queue is in use by another person."
+        ..S MSG(1,"F")="!!"
+        ..S MSG(2)="  You will need to add this accession to the queue later."
+        ..D EN^DDIOL(.MSG) K MSG
+        .S ^LRO(69.2,LRAA,1,LRAN,0)=LRDFN_"^"_LRI_"^"_LRH(0)
+        .S X=^LRO(69.2,LRAA,1,0),^(0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1)
+        .L -^LRO(69.2,LRAA,1)
+        I "CYEMSP"[LRSS,$D(LR(7)),'$D(^LRO(69.2,LRAA,2,LRAN,0)),LRD(1)'="S" D
+        .L +^LRO(69.2,LRAA,2):5 I '$T D  Q
+        ..S MSG(1)="The final reports queue is in use by another person.  "
+        ..S MSG(1,"F")="!!"
+        ..S MSG(2)="You will need to add this accession to the queue later."
+        ..D EN^DDIOL(.MSG) K MSG
+        .S ^LRO(69.2,LRAA,2,LRAN,0)=LRDFN_"^"_LRI_"^"_LRH(0)
+        .S X=^LRO(69.2,LRAA,2,0),^(0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1)
+        .L -^LRO(69.2,LRAA,2)
+        D:LRSOP="M"!(LRSOP="B") EN^LRSPGD
+        Q
+NM      ;
+        I X'["@"!(X["@"&(Y(Z)="")) D  Q
+        .W $C(7),!?4,"ENTER WHOLE NUMBERS ONLY",! K X
+        I Y(Z)'="" W $C(7),?40,"OK TO DELETE" S %=2 D YN^LRU I %'=1 K X Q
+        S Y(Z)="" Q
+        ;
+AUE     ;Autopsy Data Entry
+        W !
+        N LREL,LRQUIT,LRSNO,LRESCPT,LRCPT
+        S (LREL,LRQUIT,LRSNO,LRCPT)=0
+        S LREL=+$$GET1^DIQ(63,LRDFN_",",14.7,"I")
+        ;Determine if CPT activated
+        I $T(ES^LRCAPES)'="" S LRESCPT=$$ES^LRCAPES()
+        ;  Allow supp report to be added on verified AU
+        I LRSOP'="","AFIP"[LRSOP,LREL D  Q:LRQUIT
+        .Q:LRESCPT&("AP"[LRSOP)
+        .W $C(7),!!,"Report verified.  Cannot edit with this option!"
+        .S LRQUIT=1
+        I LRSOP'="","ABP"[LRSOP,LREL D  Q:LRQUIT
+        .W $C(7),!!,"Report has been verified.  "
+        .W "Only "
+        .I LRESCPT W "CPT " W:LRSOP="B" "and "
+        .W:LRSOP="B" "SNOMED "
+        .W "coding permitted.",!
+        .I LRSOP="B" D
+        ..K DIR S DIR(0)="Y",DIR("A")="Enter SNOMED coding",DIR("B")="NO"
+        ..D ^DIR W !
+        ..S LRSNO=+Y
+        .Q:'LRESCPT
+        .K DIR S DIR(0)="Y",DIR("A")="Enter CPT coding",DIR("B")="NO"
+        .D ^DIR W !
+        .S LRCPT=+Y
+        .I "AP"[LRSOP,'LRCPT S LRQUIT=1 Q
+        .I LRSOP="B",'LRCPT,'LRSNO S LRQUIT=1
+AURESET ;Reset DR to orig value in LRAUDA
+        I LRSOP'="","AP"[LRSOP D @(LRSOP_"DR^LRAUDA")
+        I LRSOP="B" D BDR^LRAUDA
+        S:LRSNO DR=32       ;Modify DR string if only SNOMED coding permitted
+        I 'LRSNO,LRCPT S DR=""  ;Set DR string to null inf only CPT coding
+        ;                              ;
+        ;Not all of the autopsy fields are within the AU subscript.
+        ;Therefore, we must lock the entire LRDFN.
+        L +^LR(LRDFN):5 I '$T D  Q
+        .S MSG="This record is locked by another user.  "
+        .S MSG=MSG_"Please wait and try again."
+        .D EN^DDIOL(MSG,"","!!") K MSG
+        I LRSFLG'="S" D
+        .N LRELSD S LRELSD=0
+        .S DIE="^LR(",DA=LRDFN
+        .D ^DIE
+        .S LRA=^LR(LRDFN,"AU")
+        .S LRI=$P(LRA,U)
+        .S LRAC=$P(LRA,U,6)
+        .I LRELSD D MAIN^LRAPRES1(LRDFN,LRSS,LRI,LRSF,LRP,LRAC)
+        D:LRSFLG="S" ^LRAPDSR
+        D UPDATE^LRPXRM(LRDFN,"AU")
+        L -^LR(LRDFN)
+        D:"BAP"[LRSOP AU
+        D:LRSOP="R" R
+        I LRSOP'="","ABP"[LRSOP D CPTCOD
+        Q
+AU      I '$D(^LRO(69.2,LRAA,2,LRAN,0)) D
+        .L +^LRO(69.2,LRAA,2):5 I '$T D  Q
+        ..S MSG(1)="The final reports queue is in use by another person.  "
+        ..S MSG(1,"F")="!!"
+        ..S MSG(2)="You will need to add this accession to the queue later."
+        ..D EN^DDIOL(.MSG) K MSG
+        .S ^LRO(69.2,LRAA,2,LRAN,0)=LRDFN
+        .S X=^LRO(69.2,LRAA,2,0),^(0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1)
+        .L -^LRO(69.2,LRAA,2)
+        D AU^LRSPGD
+        Q
+R       I '$D(^LRO(69.2,LRAA,3,LRAN,0)) D
+        .L +^LRO(69.2,LRAA,3):5 I '$T D  Q
+        ..S MSG(1)="The interim reports queue is in use by another person.  "
+        ..S MSG(1,"F")="!!"
+        ..S MSG(2)="You will need to add this accession to the queue later."
+        ..D EN^DDIOL(.MSG) K MSG
+        .S ^LRO(69.2,LRAA,3,LRAN,0)=LRDFN
+        .S X=^LRO(69.2,LRAA,3,0),^(0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1)
+        .L -^LRO(69.2,LRAA,3)
+        Q
+PNAME   ;Patient Name Lookup
+        N LRPFLG            ;LRPFLG tells LRUPS to limit accessions to
+        S X=LRAN,LRPFLG=1   ;the chosen year.
+        K LRAN,DIC,VADM,VAIN,VA
+        S DFN=-1,DIC(0)="EQM",(LRX,LRDPF)=""
+        D:'$D(LRLABKY) LABKEY^LRPARAM
+        D DPA1^LRDPA
+        I DFN=-1 S LRAN=-1 Q
+        D I^LRUPS
+        Q
+CPTCOD  ;CPT Coding
+        N LRPRO
+        Q:$T(CPT^LRCAPES)=""
+        Q:LREL&('LRCPT)
+        I 'LREL D
+        .K DIR S DIR(0)="Y",DIR("A")="Enter CPT coding",DIR("B")="NO"
+        .D ^DIR W !
+        .S LRCPT=+Y
+        Q:'LRCPT
+        ;SET PROVIDER TO CURRENT USER, ALLOW UPDATES
+        S LRPRO=DUZ
+        D PROVIDR^LRAPUTL
+        Q:LRQUIT
+        D CPT^LRCAPES(LRAA,LRAD,LRAN,LRPRO)
+        Q
+END     K LRSFLG
+        D:$T(CLEAN^LRCAPES)'="" CLEAN^LRCAPES
+        D V^LRU
+        Q
+LRAPDA ;AVAMC/REG/WTY/KLL - ANATOMIC PATH DATA ENTRY;11/02/01
+ ;;5.2;LAB SERVICE;**72,73,91,121,248,259,295,317**;Sep 27, 1994
+ ;
+ ;Reference to ^%DT supported by IA #10003
+ ;Reference to ^DIE supported by IA #10018
+ ;Reference to ^VA(200 supported by IA #10060
+ ;Reference to EN^DDIOL supported by IA #10142
+ ;
+ W !?20,LRO(68)," (",LRABV,")",!
+ S:'$D(LRSOP) LRSOP=1 S:'$D(LRD(1)) LRD(1)="0"
+ S:'$D(^LRO(69.2,LRAA,2,0)) ^(0)="^69.23A^0^0"
+SEL K LR(1)
+ I $D(LR(2)) D  G:%<1 END S:%=1 LR(1)=1
+ .W !!,"Enter Etiology, Function, Procedure & Disease "
+ .S %=2 D YN^LRU
+AK ;from LRAPD1
+ N CORRECT
+ S:'$D(LRSFLG) LRSFLG=""
+ W !!,"Data entry for ",LRH(0)," "
+ S %=1 D YN^LRU G:%<1 END
+ I %=2 D  G:Y<1 END S LRAD=$E(Y,1,3)_"0000",LRH(0)=$E(Y,1,3)+1700
+ .S %DT="AE",%DT(0)="-N",%DT("A")="Enter YEAR: " D ^%DT K %DT
+ I '$O(^LRO(68,LRAA,1,LRAD,1,0)) D  Q
+ .W $C(7),!!,"NO ",LRO(68)," ACCESSIONS IN FILE FOR ",LRH(0),!!
+W K X,Y,LR("CK")
+ R !!,"Select Accession Number/Pt name: ",LRAN:DTIME
+ G:LRAN=""!(LRAN[U) END
+ I LRAN["?" D  G W
+ .W !!,"Enter the year ",LRH(0)," ",LRO(68)," accession number to be "
+ .W "updated"
+ .W !,"or locate the accession by entering the patient name."
+ I LRAN'?1N.N D PNAME G:LRAN<1 W D OE1^LR7OB63D,REST,OERR^LR7OB63D G W
+ D OE1^LR7OB63D,REST S:$D(DR(1))#2 DR=DR(1) D OERR^LR7OB63D G W
+REST ;
+ N LRXSTOP,LRX,LRX1
+ W "  for ",LRH(0)
+ I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D  Q
+ .W $C(7),!!,"Accession # ",LRAN," for ",LRH(0)," not in ",LRO(68),!!
+ S X=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRLLOC=$P(X,"^",7),LRDFN=+X
+ Q:'$D(^LR(LRDFN,0))  S X=^(0) D ^LRUP
+ W !,LRP,"  ID: ",SSN
+ S LRI=+$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5)
+ I LRSS'="AU",'$D(^LR(LRDFN,LRSS,LRI,0)) D  Q
+ .W $C(7),!,"Inverse date missing or incorrect in Accession Area file "
+ .W "for",!,LRO(68),"  Year: ",$E(LRAD,2,3),"  Accession: ",LRAN
+ I "SPCYEM"[LRSS,$O(^LR(LRDFN,LRSS,LRI,.1,0)) D
+ .W !,"Specimen(s):"
+ .S X=0 F  S X=$O(^LR(LRDFN,LRSS,LRI,.1,X)) Q:'X  D
+ ..W !,$P($G(^LR(LRDFN,LRSS,LRI,.1,X,0)),"^")
+ ;
+ ;Don't allow supp. report to be added to a released report if
+ ; modifications are being added via MM option
+ S LRXSTOP=0,(LRX,LRX1)=""
+ I LRSS'="AU",LRD(1)="S" D
+ .S LRX=$P($G(^LR(LRDFN,LRSS,LRI,0)),"^",11) ;release date/time
+ .S LRX1=$P($G(^LR(LRDFN,LRSS,LRI,0)),"^",15) ;orig rel date/time
+ I LRSS="AU",LRSOP="R" D
+ .S LRX=$P($G(^LR(LRDFN,"AU")),"^",15)  ;release date/time
+ .S LRX1=$P($G(^LR(LRDFN,"AU")),"^",3)  ;date report completed
+ I 'LRX,LRX1 D
+ .W $C(7),!!,"This "_$G(LRAA(1))_" report is currently being"
+ .W !,"modified; it must first be released before Supplementary"
+ .W !,"report can be added.",!
+ .S LRXSTOP=1
+ Q:LRXSTOP
+ ;
+DIE ;Edit
+ I LRSS="AU" D AUE Q
+ N LRRDT1,LRRDT2,LRIENS,LREL,LRQUIT,LRSNO,LRCPT,LRESCPT
+ S (LREL,LRESCPT,LRQUIT,LRSNO,LRCPT)=0,LRIENS=LRI_","_LRDFN_","
+ S LRRDT1=$$GET1^DIQ(LRSF,LRIENS,.11,"I")
+ S LRRDT2=$$GET1^DIQ(LRSF,LRIENS,.15,"I")
+ S:LRRDT1!LRRDT2 LREL=1
+ I $T(ES^LRCAPES)'="" S LRESCPT=$$ES^LRCAPES()
+ I LRSOP="G",LREL D  Q
+ .W $C(7),!!,"Report verified.  Cannot edit with this option."
+ I LRSOP'="","ABM"[LRSOP,LREL D  Q:LRQUIT
+ .;Allow SNOMED and CPT coding even after release.
+ .W $C(7),!!,"Report has been verified.  "
+ .I 'LRESCPT,LRSOP'="B" D  Q
+ ..W "Cannot edit with this option."
+ ..S LRQUIT=1
+ .W "Only "
+ .I LRESCPT W "CPT " W:LRSOP="B" "and "
+ .W:LRSOP="B" "SNOMED "
+ .W "coding permitted.",!
+ .I LRSOP="B" D
+ ..K DIR S DIR(0)="Y",DIR("A")="Enter SNOMED coding",DIR("B")="NO"
+ ..D ^DIR W !
+ ..S LRSNO=+Y
+ .Q:'LRESCPT
+ .K DIR S DIR(0)="Y",DIR("A")="Enter CPT coding",DIR("B")="NO"
+ .D ^DIR W !
+ .S LRCPT=+Y
+ .I "AM"[LRSOP,'LRCPT S LRQUIT=1 Q
+ .I LRSOP="B",'LRCPT,'LRSNO S LRQUIT=1
+RESET ;Reset DR string if altered by prior accession/patient
+ ;Reset DR to orig value in LRAPD1
+ I LRSOP'="","AMBS"[LRSOP,$G(LRD)'="" D @LRD
+ I LRSFLG="S",$G(LRD)'="" D @LRD  ;For CY,EM Supp entry
+ S:LRSNO DR=10    ;Modify DR string if only SNOMED coding permitted
+ I 'LRSNO,LRCPT S DR=""  ;Set DR string to null in only CPT coding
+ ;If adding supp rpt to released rpt, remove date rpt completed from DR
+ I LRRDT1,LRSOP="S"!(LRSFLG="S") S DR=".09///^S X=LRWHO;10"
+EDIT ;Call to ^DIE
+ W ! S LRA=^LR(LRDFN,LRSS,LRI,0),LRRC=$P(LRA,"^",10)
+ I LRCAPA,"SPCYEM"[LRSS D C^LRAPSWK
+ S DIE="^LR(LRDFN,LRSS,",DA=LRI,DA(1)=LRDFN
+ D CK^LRU Q:$D(LR("CK"))
+ I LRSS="SP",LRSOP="B",$O(^LR(LRDFN,LRSS,LRI,1.3,0)) D
+ .W $C(7),!!,"This accession has a FROZEN SECTION report."
+ .W !,"Be sure 'FROZEN SECTION' is entered as a SNOMED code in the "
+ .W "PROCEDURE field"
+ .W !,"for the appropriate organ or tissue.",!!
+ D ^DIE
+ D UPDATE^LRPXRM(LRDFN,LRSS,LRI)
+ D:LRSFLG="S"&('$D(Y)) ^LRAPDSR
+ D FRE^LRU
+ I LRSOP'="","ABM"[LRSOP D CPTCOD
+WKLD ;Capture Workload
+ I LRSOP="Z","CYSP"[LRSS,LRCAPA D S^LRAPR Q
+ I LRCAPA,"SPCYEM"[LRSS,LRD(1)'="","MBA"[LRD(1) D C1^LRAPSWK
+ I LRCAPA,"SPCYEM"[LRSS,LRSOP="G" D C1^LRAPSWK
+QUEUES ;Update Queues
+ S X=$P(^LR(LRDFN,LRSS,LRI,0),"^",4)
+ I X,$D(^VA(200,X,0)) S LR("TR")=$P(^(0),"^")
+ I "CYEMSP"[LRSS,$D(LR(6)),LRSOP="G" Q:$D(^LRO(69.2,LRAA,1,LRAN,0))  D  Q
+ .L +^LRO(69.2,LRAA,1):5 I '$T D  Q
+ ..S MSG(1)="The preliminary reports queue is in use by another person."
+ ..S MSG(1,"F")="!!"
+ ..S MSG(2)="  You will need to add this accession to the queue later."
+ ..D EN^DDIOL(.MSG) K MSG
+ .S ^LRO(69.2,LRAA,1,LRAN,0)=LRDFN_"^"_LRI_"^"_LRH(0)
+ .S X=^LRO(69.2,LRAA,1,0),^(0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1)
+ .L -^LRO(69.2,LRAA,1)
+ I "CYEMSP"[LRSS,$D(LR(7)),'$D(^LRO(69.2,LRAA,2,LRAN,0)),LRD(1)'="S" D
+ .L +^LRO(69.2,LRAA,2):5 I '$T D  Q
+ ..S MSG(1)="The final reports queue is in use by another person.  "
+ ..S MSG(1,"F")="!!"
+ ..S MSG(2)="You will need to add this accession to the queue later."
+ ..D EN^DDIOL(.MSG) K MSG
+ .S ^LRO(69.2,LRAA,2,LRAN,0)=LRDFN_"^"_LRI_"^"_LRH(0)
+ .S X=^LRO(69.2,LRAA,2,0),^(0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1)
+ .L -^LRO(69.2,LRAA,2)
+ D:LRSOP="M"!(LRSOP="B") EN^LRSPGD
+ Q
+NM ;
+ I X'["@"!(X["@"&(Y(Z)="")) D  Q
+ .W $C(7),!?4,"ENTER WHOLE NUMBERS ONLY",! K X
+ I Y(Z)'="" W $C(7),?40,"OK TO DELETE" S %=2 D YN^LRU I %'=1 K X Q
+ S Y(Z)="" Q
+ ;
+AUE ;Autopsy Data Entry
+ W !
+ N LREL,LRQUIT,LRSNO,LRESCPT,LRCPT
+ S (LREL,LRQUIT,LRSNO,LRCPT)=0
+ S LREL=+$$GET1^DIQ(63,LRDFN_",",14.7,"I")
+ I $T(ES^LRCAPES)'="" S LRESCPT=$$ES^LRCAPES()
+ ;  Allow supp report to be added on verified AU
+ I LRSOP'="","AFIP"[LRSOP,LREL D  Q:LRQUIT
+ .Q:LRESCPT&("AP"[LRSOP)
+ .W $C(7),!!,"Report verified.  Cannot edit with this option!"
+ .S LRQUIT=1
+ I LRSOP'="","ABP"[LRSOP,LREL D  Q:LRQUIT
+ .W $C(7),!!,"Report has been verified.  "
+ .W "Only "
+ .I LRESCPT W "CPT " W:LRSOP="B" "and "
+ .W:LRSOP="B" "SNOMED "
+ .W "coding permitted.",!
+ .I LRSOP="B" D
+ ..K DIR S DIR(0)="Y",DIR("A")="Enter SNOMED coding",DIR("B")="NO"
+ ..D ^DIR W !
+ ..S LRSNO=+Y
+ .Q:'LRESCPT
+ .K DIR S DIR(0)="Y",DIR("A")="Enter CPT coding",DIR("B")="NO"
+ .D ^DIR W !
+ .S LRCPT=+Y
+ .I "AP"[LRSOP,'LRCPT S LRQUIT=1 Q
+ .I LRSOP="B",'LRCPT,'LRSNO S LRQUIT=1
+AURESET ;Reset DR to orig value in LRAUDA
+ I LRSOP'="","AP"[LRSOP D @(LRSOP_"DR^LRAUDA")
+ I LRSOP="B" D BDR^LRAUDA
+ S:LRSNO DR=32       ;Modify DR string if only SNOMED coding permitted
+ I 'LRSNO,LRCPT S DR=""  ;Set DR string to null inf only CPT coding
+ ;                              ;
+ ;Not all of the autopsy fields are within the AU subscript.
+ ;Therefore, we must lock the entire LRDFN.
+ L +^LR(LRDFN):5 I '$T D  Q
+ .S MSG="This record is locked by another user.  "
+ .S MSG=MSG_"Please wait and try again."
+ .D EN^DDIOL(MSG,"","!!") K MSG
+ I LRSFLG'="S" D
+ .S DIE="^LR(",DA=LRDFN
+ .D ^DIE
+ D:LRSFLG="S" ^LRAPDSR
+ D UPDATE^LRPXRM(LRDFN,"AU")
+ L -^LR(LRDFN)
+ D:"BAP"[LRSOP AU
+ D:LRSOP="R" R
+ I LRSOP'="","ABP"[LRSOP D CPTCOD
+ Q
+AU I '$D(^LRO(69.2,LRAA,2,LRAN,0)) D
+ .L +^LRO(69.2,LRAA,2):5 I '$T D  Q
+ ..S MSG(1)="The final reports queue is in use by another person.  "
+ ..S MSG(1,"F")="!!"
+ ..S MSG(2)="You will need to add this accession to the queue later."
+ ..D EN^DDIOL(.MSG) K MSG
+ .S ^LRO(69.2,LRAA,2,LRAN,0)=LRDFN
+ .S X=^LRO(69.2,LRAA,2,0),^(0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1)
+ .L -^LRO(69.2,LRAA,2)
+ D AU^LRSPGD
+ Q
+R I '$D(^LRO(69.2,LRAA,3,LRAN,0)) D
+ .L +^LRO(69.2,LRAA,3):5 I '$T D  Q
+ ..S MSG(1)="The interim reports queue is in use by another person.  "
+ ..S MSG(1,"F")="!!"
+ ..S MSG(2)="You will need to add this accession to the queue later."
+ ..D EN^DDIOL(.MSG) K MSG
+ .S ^LRO(69.2,LRAA,3,LRAN,0)=LRDFN
+ .S X=^LRO(69.2,LRAA,3,0),^(0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1)
+ .L -^LRO(69.2,LRAA,3)
+ Q
+PNAME ;Patient Name Lookup
+ N LRPFLG            ;LRPFLG tells LRUPS to limit accessions to
+ S X=LRAN,LRPFLG=1   ;the chosen year.
+ K LRAN,DIC,VADM,VAIN,VA
+ S DFN=-1,DIC(0)="EQM",(LRX,LRDPF)=""
+ D:'$D(LRLABKY) LABKEY^LRPARAM
+ D DPA1^LRDPA
+ I DFN=-1 S LRAN=-1 Q
+ D I^LRUPS
+ Q
+CPTCOD ;CPT Coding
+ N LRPRO
+ Q:$T(CPT^LRCAPES)=""
+ Q:LREL&('LRCPT)
+ I 'LREL D
+ .K DIR S DIR(0)="Y",DIR("A")="Enter CPT coding",DIR("B")="NO"
+ .D ^DIR W !
+ .S LRCPT=+Y
+ Q:'LRCPT
+ ;SET PROVIDER TO CURRENT USER, ALLOW UPDATES
+ S LRPRO=DUZ
+ D PROVIDR^LRAPUTL
+ Q:LRQUIT
+ D CPT^LRCAPES(LRAA,LRAD,LRAN,LRPRO)
+ Q
+END K LRSFLG
+ D:$T(CLEAN^LRCAPES)'="" CLEAN^LRCAPES
+ D V^LRU
+ Q

WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRAPR.m

-              r613
+              r623
+LRAPR   ;DALOI/REG/WTY/KLL/CKA - ANAT RELEASE REPORTS ;10/30/01
+        ;;5.2;LAB SERVICE;**72,248,259,317,365**;Sep 27, 1994;Build 9
+        ;
+        N LRESSW
+        D SWITCH
+        I +LRESSW D  Q
+        .D ^LRAPRES
+        .D END
+        W !!?27,"Release Pathology Reports",!!
+        D A
+        I '$D(LRSS) D END Q
+        I LRCAPA D  G:'$D(X) END
+        .S X=$S(LRSS="CY":"CYTOLOGY REPORTING",LRSS="SP":"SURGICAL PATH REPORTING",1:"")
+        .D:X]"" X^LRUWK
+        I LRSS="AU" D B Q
+        S LRSOP="Z"
+        S DR="S A=^LR(LRDFN,LRSS,LRI,0),LRZ=$P(A,U,3),LRZ(1)=$P(A,U,13),"
+        S DR=DR_"LRZ(2)=$P(A,U,11),LRZ(3)=$P(A,U,2);"
+        S DR=DR_"I 'LRZ W $C(7),!,""No date report completed.   "
+        S DR=DR_"Cannot release."" S Y=0;"
+        S DR=DR_"I 'LRZ(2) D NMPATH^LRAPR;"
+        S DR=DR_"I LRZ(2) D RINFO^LRAPR S Y=0;"
+        ;Perform supp edit regardless if date rept released since supp rpt
+        ; is added to released report
+        S DR=DR_"D SUPCHK^LRAPR;"
+        S DR=DR_"S DIR(0)=""YA"",DIR(""A"")=""Release report? """
+        S DR=DR_",DIR(""B"")=""NO"" D ^DIR K:Y Y S:$D(Y) Y=0;"
+        S DR=DR_".11////^D NOW^%DTC S X=%;.13////^S X=DUZ;"
+        S DR=DR_"S LRELSD=1 W !!,""Report released..."""
+        D ^LRAPDA
+        D END
+        Q
+        ;
+B       ;Autopsy
+        S LRSOP="Z"
+        S DR="S A=$G(^LR(LRDFN,""AU"")) I A="""" S Y=0;"
+        S DR=DR_"S LRZ=$P(A,U,3),LRZ(1)=$P(A,U,16),LRZ(2)=$P(A,U,15),"
+        ;KLL-LRZ(3)=SR PATHOLOGIST,LRZ(4)=PROVISIONAL DATE
+        S DR=DR_"LRZ(3)=$P(A,U,10),LRZ(4)=$P(A,U,17);"
+        ;KLL-PROVISIONAL OR DATE REPORT COMPLETED IS REQUIRED
+        S DR=DR_"I 'LRZ(4),'LRZ W $C(7),!,""Provisional date or date report completed required.   "
+        S DR=DR_"Cannot release."" S Y=0;"
+        S DR=DR_"I 'LRZ(2) D NMPATH^LRAPR;"
+        S DR=DR_"I LRZ(2) D RINFO^LRAPR S Y=0;"
+        ;Perform supp edit regardless if date rept released since supp rpt
+        ; is added to released report
+        S DR=DR_"D SUPCHK^LRAPR;"
+        S DR=DR_"D RELEASE^LRAPR;"
+        S DR=DR_"D NOW^%DTC S LRDTE=%;"
+        S DR=DR_"14.7////^S X=$S(LRZ(2):""@"",1:LRDTE);"
+        S DR=DR_"14.8////^S X=$S(LRZ(2):""@"",1:DUZ);"
+        S DR=DR_"S:'LRZ(2) LRELSD=1 "
+        S DR=DR_"W !!,""Report "" W:LRZ(2) ""un"" W ""released..."";K LRDTE"
+        D ^LRAPDA
+        D END
+        Q
+EN      ;Supplementary Report Entry Point
+        N LRESSW
+        D SWITCH
+        W !!?20,"Release Supplementary Pathology Reports",!
+        ;D A
+        ;Section prompt replaces the line above
+        S LRQUIT=0
+        D SECTION^LRAPRES
+        I '$D(LRSS) D END Q
+        ;Verify User ID has access to release supp. reports
+        S LREND=0
+        I LRESSW D CLSSCHK^LRAPRES1(DUZ,.LREND)
+        Q:LREND
+        ;
+        W !!,"Data entry for ",LRH(0)," "
+        S %=1 D YN^LRU G:%<1 END
+        I %=2 D  G:Y<1 END
+        .S %DT="AE",%DT(0)="-N",%DT("A")="Enter YEAR: " D ^%DT K %DT
+        .Q:Y<1  S LRAD=$E(Y,1,3)_"0000",LRH(0)=$E(Y,1,3)+1700
+        I '$D(^LRO(68,LRAA,1,LRAD,0)) D  Q
+        .W $C(7),!!,"NO ",LRAA(1)," ACCESIONS IN FILE FOR ",LRH(0),!!
+W       K X,Y,LR("CK") R !!,"Select Accession Number/Pt name: ",LRAN:DTIME
+        G:LRAN=""!(LRAN[U) END
+        I LRAN'?1N.N D  G:LRAN<1 END  G W
+        .D PNAME^LRAPDA
+        .Q:LRAN<1
+        .D DIE
+        D REST
+        G W
+REST    W "  for ",LRH(0)
+        I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D  Q
+        .W $C(7),!!,"Accession # ",LRAN," for ",LRH(0)
+        .W " not in ACCESSION file",!!
+        S X=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRLLOC=$P(X,"^",7),LRDFN=+X
+        Q:'$D(^LR(LRDFN,0))  S X=^(0) D ^LRUP
+        W !,LRP,"  ID: ",SSN
+        I LRSS'="AU" D
+        .S LRI=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),"^",5)
+        .W !,"Specimen(s):"
+        .S X=0 F  S X=$O(^LR(LRDFN,LRSS,LRI,.1,X)) Q:'X  D
+        ..I $D(^LR(LRDFN,LRSS,LRI,.1,X,0)),$L(^(0)) W !,^(0)
+DIE     ;Define default supplementary report
+        N LRFILE,LRIENS,LRIENS1,LRX,LRRLS,LRFDA,LRLKFL,LRDA,LRQUIT,LRNOSP
+        N LRMSG,LRSRFL,LRFDA2,LRSRMD,LRRLM
+        S DIC("B")="",LRNOSP=0
+        I LRSS'="AU" D
+        .S LRFILE=+$$GET1^DID(LRSF,1.2,"","SPECIFIER")
+        .S LRIENS1=LRI_","_LRDFN_","
+        .I '+$P($G(^LR(LRDFN,LRSS,LRI,1.2,0)),"^",4) S LRNOSP=1 Q
+        .S LRX=0 F  S LRX=$O(^LR(LRDFN,LRSS,LRI,1.2,LRX)) Q:'LRX  D
+        ..S LRIENS=LRX_","_LRIENS1
+        ..S LRSRFL=$$GET1^DIQ(LRFILE,LRIENS,.02,"I")
+        ..;LRSRMD-set to 1 if supp rpt modified and requires release
+        ..S LRSRMD=$$GET1^DIQ(LRFILE,LRIENS,.03,"I")
+        ..Q:LRSRFL&('LRSRMD)
+        ..S DIC("B")=$$GET1^DIQ(LRFILE,LRIENS,.01,"I")
+        I LRSS="AU" D
+        .S LRFILE=63.324,LRIENS1=LRDFN_","
+        .I '+$P($G(^LR(LRDFN,84,0)),"^",4) S LRNOSP=1 Q
+        .S LRX=0 F  S LRX=$O(^LR(LRDFN,84,LRX)) Q:'LRX  D
+        ..S LRIENS=LRX_","_LRIENS1
+        ..S LRSRFL=$$GET1^DIQ(LRFILE,LRIENS,.02,"I")
+        ..;LRSRMD-set to 1 if supp rpt modified and requires release
+        ..S LRSRMD=$$GET1^DIQ(LRFILE,LRIENS,.03,"I")
+        ..Q:LRSRFL&('LRSRMD)
+        ..S DIC("B")=$$GET1^DIQ(LRFILE,LRIENS,.01,"I")
+        I LRNOSP D  Q
+        .K LRMSG
+        .S LRMSG=$C(7)_"No supplementary reports exist for this accession."
+        .D EN^DDIOL(LRMSG,"","!!")
+        I 'DIC("B") D  Q
+        .K LRMSG
+        .S LRMSG=$C(7)_"All supplementary reports have been released."
+        .D EN^DDIOL(LRMSG,"","!!")
+DIE1    ;
+        S (LRQUIT,LRRLM)=0
+        F  D  Q:LRQUIT
+        .W !
+        .S:LRSS="AU" (LRLKFL,DIC)="^LR(LRDFN,84,"
+        .S:LRSS'="AU" (LRLKFL,DIC)="^LR(LRDFN,LRSS,LRI,1.2,"
+        .S DIC("A")="Select SUPPLEMENTARY REPORT DATE: "
+        .S DIC(0)="AEQM"
+        .D ^DIC K DIC
+        .I Y<1 S LRQUIT=1 Q
+        .S LRDA=+Y
+        .S LRIENS=LRDA_","_LRIENS1
+        .S LRRLS=+$$GET1^DIQ(LRFILE,LRIENS,.02,"I")
+        .;If E-Sign OFF, must check LRRLM.  LRRLM=1 if supp rpt has been
+        .;  modified and requires release
+        .S LRRLM=+$$GET1^DIQ(LRFILE,LRIENS,.03,"I")
+        .I LRESSW,LRRLS D  Q
+        ..W !!,"This supplementary report has already been released.",!
+        .I 'LRESSW,LRRLS D  Q:'LRRLM
+        ..I 'LRRLM W !!,"This supplementary rept has already been released.",!
+        .W !
+        .I LRESSW D  Q
+        ..D ESIG Q:LRQUIT
+        ..D UPDATE
+        .S DIR("A")="Release supplementary report",DIR(0)="Y",DIR("B")="NO"
+        .D ^DIR K DIR
+        .Q:'Y
+        .D UPDATE
+        .;If E-sign switch OFF and orig report released, must verify all
+        .;  supp reports released before release main report.
+        .I LRCKREL,'LRESSW D CHKSUP^LRAPR1
+        Q
+        ;
+A       D ^LRAP G:'$D(Y) END
+        Q
+C       ;
+        S LRDICS="SPCYEM" D ^LRAP
+        G:'$D(Y) END
+        Q
+S       ;from LRAPDA
+        S LRK=$P(^LR(LRDFN,LRSS,LRI,0),"^",11) Q:'LRK  S:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)) ^(0)="^68.04PA^^"
+        Q:$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0))  S ^(0)=LRT_"^50^^"_DUZ_"^"_LRK,X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),^(0)=$P(X,"^",1,2)_"^"_LRT_"^"_($P(X,"^",4)+1)
+        S:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0)) ^(0)="^68.14P^^"
+        S C=0 F  S C=$O(LRT(C)) Q:'C  D CAP
+        S ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_LRT)=""
+        Q
+        ;
+CAP     S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,C,0)=C_"^1^0^0^^"_LRK_"^"_DUZ_"^"_DUZ(2)_"^"_LRAA_"^"_LRAA_"^"_LRAA
+        S X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0),^(0)=$P(X,"^",1,2)_"^"_C_"^"_($P(X,"^",4)+1)
+        Q
+        ;
+SWITCH  ;Check to see if electronic signature is enabled
+        D GETDATA^LRAPESON(.LRESSW)
+        Q
+ESIG    ;Prompt for electronic signature
+        S LRQUIT=0
+        D SIG^XUSESIG
+        I X1="" D
+        .W "  SIGNATURE NOT VERIFIED"
+        .S LRQUIT=1
+        Q
+UPDATE  ;
+        S LRLKFL=LRLKFL_LRDA_",0)"
+        L +@(LRLKFL):5 I '$T D  Q
+        .S LRMSG="This record is locked by another user.  "
+        .S LRMSG=LRMSG_"Please wait and try again."
+        .D EN^DDIOL(LRMSG,"","!!")
+        S LRFDA(LRFILE,LRIENS,.02)=1
+        S LRFDA2(LRFILE,LRIENS,.02)="@" ;Set but don't file unless unrel needed
+        ;File signer ID and Date/time of released supp report
+        D CKSIGNR^LRAPR1
+        D FILE^DIE("","LRFDA")
+        W "...Released"
+        L -@(LRLKFL)
+        I LRSS="AU" D
+        .S LRA=^LR(LRDFN,"AU")
+        .S LRAC=$$GET1^DIQ(63,LRDFN_",",14,"I")
+        .S LRI=$P(LRA,U)
+        I LRSS'="AU" D
+        .S LRA=^LR(LRDFN,LRSS,LRI,0)
+        .S LRAC=$$GET1^DIQ(LRSF,LRIENS,.06,"I")
+        D MAIN^LRAPRES1(LRDFN,LRSS,LRI,LRSF,LRP,LRAC)
+        ;If all supp reports released, and E-Sign switch is ON, proceed to
+        ;  release main report
+        S LRCKREL=0
+        S:LRSS'="AU" LRCKREL=$P(^LR(LRDFN,LRSS,LRI,0),"^",11)
+        S:LRSS="AU" LRCKREL=$P(^LR(LRDFN,LRSS),"^",15)
+        I LRCKREL,LRESSW D RELMN
+        Q
+SUPCHK  ;Check for unreleased supplementary reports
+        N LRSR,LRSR1,LRSR2
+        S LRSR=0,LRSR1=1
+        I LRSS'="AU" D
+        .Q:'+$P($G(^LR(LRDFN,LRSS,LRI,1.2,0)),U,4)
+        .F  S LRSR=$O(^LR(LRDFN,LRSS,LRI,1.2,LRSR)) Q:LRSR'>0!('LRSR1)  D
+        ..S LRSR1=+$P(^LR(LRDFN,LRSS,LRI,1.2,LRSR,0),U,2)
+        ..I 'LRSR1 D
+        ...S Y=+$P(^LR(LRDFN,LRSS,LRI,1.2,LRSR,0),U)
+        ...D DD^%DT S LRSR2=Y
+        I LRSS="AU" D
+        .Q:'+$P($G(^LR(LRDFN,84,0)),U,4)
+        .F  S LRSR=$O(^LR(LRDFN,84,LRSR)) Q:LRSR'>0!('LRSR1)  D
+        ..S LRSR1=+$P(^LR(LRDFN,84,LRSR,0),U,2)
+        ..I 'LRSR1 D
+        ...S Y=+$P(^LR(LRDFN,84,LRSR,0),U)
+        ...D DD^%DT S LRSR2=Y
+        I 'LRSR1 D
+        .W $C(7),!,"Supplementary report "_LRSR2_" has not been released.  "
+        .W "Cannot release."
+        .S Y=0
+        Q
+RINFO   ;Display release information
+        W $C(7),!,"Report "
+        W:LRZ(2)=1 "has already been "
+        W "released "
+        S Y=LRZ(2)
+        D DD^%DT
+        W:LRZ(2)>1 Y
+        W:LRZ(1)'="" " by "_$P($G(^VA(200,LRZ(1),0)),U)
+        K Y
+        Q
+NMPATH  ;Check for missing pathologist name
+        I 'LRZ(3) D
+        .W $C(7),!,"Pathologist name missing.  Cannot release."
+        .S Y=0
+        Q
+RELEASE ;Prompt for release/unrelease
+        W ! S DIR(0)="YA",DIR("B")="NO"
+        S:LRZ(2) DIR("A")="Unrelease report? "
+        S:'LRZ(2) DIR("A")="Release report? "
+        D ^DIR
+        K:Y Y
+        I $D(Y) S Y=0
+        Q
+RELMN   ;Allow release of main report as long as all supp reports are
+        ;  released, and signer is same person for main and supp report(s)
+        ;Make sure all supp reports signed out
+        S LRQT=0
+        D RELCHK^LRAPR1
+        Q:LRQT
+        ;
+        ;Continue with electronic signature and storage in TIU
+        S LRAU=$S(LRSS="AU":1,1:0)
+        I 'LRAU D
+        .S LRPAT=+$$GET1^DIQ(LRSF,LRIENS1,.02,"I")
+        .S LRZ=$$GET1^DIQ(LRSF,LRIENS1,.03,"I")
+        .S LRZ(1)=$$GET1^DIQ(LRSF,LRIENS1,.13,"I")
+        .S LRZ(1.1)=$$GET1^DIQ(LRSF,LRIENS1,.13)
+        .S LRZ(2)=$$GET1^DIQ(LRSF,LRIENS1,.11,"I")
+        I LRAU D
+        .S LRPAT=+$$GET1^DIQ(63,LRDFN_",",13.6,"I")
+        .S LRZ=$$GET1^DIQ(63,LRDFN_",",13,"I")
+        .S LRZ(1)=$$GET1^DIQ(63,LRDFN_",",14.8,"I")
+        .S LRZ(1.1)=$$GET1^DIQ(63,LRDFN_",",14.8)
+        .S LRZ(2)=$$GET1^DIQ(63,LRDFN_",",14.7,"I")
+        W !!,?25,"*** Main Report Release ***",!
+        D NOW^%DTC S LRNTIME=%
+        D TIUPREP^LRAPRES
+        D STORE^LRAPRES
+        I LRQUIT D FILE^DIE("","LRFDA2") Q
+        D UNRLSE^LRAPR1
+        D RELEASE^LRAPRES
+        I LRQUIT D FILE^DIE("","LRFDA2") Q
+        D OERR^LR7OB63D
+        S LRQUIT=1
+        Q
+END     ;
+        D V^LRU
+        Q
+LRAPR ;AVAMC/REG/WTY/KLL- ANAT RELEASE REPORTS ;10/30/01
+ ;;5.2;LAB SERVICE;**72,248,259,317**;Sep 27, 1994
+ ;
+ N LRESSW
+ D SWITCH
+ I +LRESSW D  Q
+ .D ^LRAPRES
+ .D END
+ W !!?27,"Release Pathology Reports",!!
+ D A
+ I '$D(LRSS) D END Q
+ I LRCAPA D  G:'$D(X) END
+ .S X=$S(LRSS="CY":"CYTOLOGY REPORTING",LRSS="SP":"SURGICAL PATH REPORTING",1:"")
+ .D:X]"" X^LRUWK
+ I LRSS="AU" D B Q
+ S LRSOP="Z"
+ S DR="S A=^LR(LRDFN,LRSS,LRI,0),LRZ=$P(A,U,3),LRZ(1)=$P(A,U,13),"
+ S DR=DR_"LRZ(2)=$P(A,U,11),LRZ(3)=$P(A,U,2);"
+ S DR=DR_"I 'LRZ W $C(7),!,""No date report completed.   "
+ S DR=DR_"Cannot release."" S Y=0;"
+ S DR=DR_"I 'LRZ(2) D NMPATH^LRAPR;"
+ S DR=DR_"I LRZ(2) D RINFO^LRAPR S Y=0;"
+ ;Perform supp edit regardless if date rept released since supp rpt
+ ; is added to released report
+ S DR=DR_"D SUPCHK^LRAPR;"
+ S DR=DR_"S DIR(0)=""YA"",DIR(""A"")=""Release report? """
+ S DR=DR_",DIR(""B"")=""NO"" D ^DIR K:Y Y S:$D(Y) Y=0;"
+ S DR=DR_".11////^D NOW^%DTC S X=%;.13////^S X=DUZ;"
+ S DR=DR_"W !!,""Report released..."""
+ D ^LRAPDA
+ D END
+ Q
+ ;
+B ;Autopsy
+ S LRSOP="Z"
+ S DR="S A=$G(^LR(LRDFN,""AU"")) I A="""" S Y=0;"
+ S DR=DR_"S LRZ=$P(A,U,3),LRZ(1)=$P(A,U,16),LRZ(2)=$P(A,U,15),"
+ ;KLL-LRZ(3)=SR PATHOLOGIST,LRZ(4)=PROVISIONAL DATE
+ S DR=DR_"LRZ(3)=$P(A,U,10),LRZ(4)=$P(A,U,17);"
+ ;KLL-PROVISIONAL OR DATE REPORT COMPLETED IS REQUIRED
+ S DR=DR_"I 'LRZ(4),'LRZ W $C(7),!,""Provisional date or date report completed required.   "
+ S DR=DR_"Cannot release."" S Y=0;"
+ S DR=DR_"I 'LRZ(2) D NMPATH^LRAPR;"
+ S DR=DR_"I LRZ(2) D RINFO^LRAPR S Y=0;"
+ ;Perform supp edit regardless if date rept released since supp rpt
+ ; is added to released report
+ S DR=DR_"D SUPCHK^LRAPR;"
+ S DR=DR_"D RELEASE^LRAPR;"
+ S DR=DR_"D NOW^%DTC S LRDTE=%;"
+ S DR=DR_"14.7////^S X=$S(LRZ(2):""@"",1:LRDTE);"
+ S DR=DR_"14.8////^S X=$S(LRZ(2):""@"",1:DUZ);"
+ S DR=DR_"W !!,""Report "" W:LRZ(2) ""un"" W ""released..."";K LRDTE"
+ D ^LRAPDA
+ D END
+ Q
+EN ;Supplementary Report Entry Point
+ N LRESSW
+ D SWITCH
+ W !!?20,"Release Supplementary Pathology Reports",!
+ ;D A
+ ;Section prompt replaces the line above
+ S LRQUIT=0
+ D SECTION^LRAPRES
+ I '$D(LRSS) D END Q
+ ;Verify User ID has access to release supp. reports
+ S LREND=0
+ I LRESSW D CLSSCHK^LRAPRES1(DUZ,.LREND)
+ Q:LREND
+ ;
+ W !!,"Data entry for ",LRH(0)," "
+ S %=1 D YN^LRU G:%<1 END
+ I %=2 D  G:Y<1 END
+ .S %DT="AE",%DT(0)="-N",%DT("A")="Enter YEAR: " D ^%DT K %DT
+ .Q:Y<1  S LRAD=$E(Y,1,3)_"0000",LRH(0)=$E(Y,1,3)+1700
+ I '$D(^LRO(68,LRAA,1,LRAD,0)) D  Q
+ .W $C(7),!!,"NO ",LRAA(1)," ACCESIONS IN FILE FOR ",LRH(0),!!
+W K X,Y,LR("CK") R !!,"Select Accession Number/Pt name: ",LRAN:DTIME
+ G:LRAN=""!(LRAN[U) END
+ I LRAN'?1N.N D  G:LRAN<1 END  G W
+ .D PNAME^LRAPDA
+ .Q:LRAN<1
+ .D DIE
+ D REST
+ G W
+REST W "  for ",LRH(0)
+ I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D  Q
+ .W $C(7),!!,"Accession # ",LRAN," for ",LRH(0)
+ .W " not in ACCESSION file",!!
+ S X=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRLLOC=$P(X,"^",7),LRDFN=+X
+ Q:'$D(^LR(LRDFN,0))  S X=^(0) D ^LRUP
+ W !,LRP,"  ID: ",SSN
+ I LRSS'="AU" D
+ .S LRI=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),"^",5)
+ .W !,"Specimen(s):"
+ .S X=0 F  S X=$O(^LR(LRDFN,LRSS,LRI,.1,X)) Q:'X  D
+ ..I $D(^LR(LRDFN,LRSS,LRI,.1,X,0)),$L(^(0)) W !,^(0)
+DIE ;Define default supplementary report
+ N LRFILE,LRIENS,LRIENS1,LRX,LRRLS,LRFDA,LRLKFL,LRDA,LRQUIT,LRNOSP
+ N LRMSG,LRSRFL,LRFDA2,LRSRMD,LRRLM
+ S DIC("B")="",LRNOSP=0
+ I LRSS'="AU" D
+ .S LRFILE=+$$GET1^DID(LRSF,1.2,"","SPECIFIER")
+ .S LRIENS1=LRI_","_LRDFN_","
+ .I '+$P($G(^LR(LRDFN,LRSS,LRI,1.2,0)),"^",4) S LRNOSP=1 Q
+ .S LRX=0 F  S LRX=$O(^LR(LRDFN,LRSS,LRI,1.2,LRX)) Q:'LRX  D
+ ..S LRIENS=LRX_","_LRIENS1
+ ..S LRSRFL=$$GET1^DIQ(LRFILE,LRIENS,.02,"I")
+ ..;LRSRMD-set to 1 if supp rpt modified and requires release
+ ..S LRSRMD=$$GET1^DIQ(LRFILE,LRIENS,.03,"I")
+ ..Q:LRSRFL&('LRSRMD)
+ ..S DIC("B")=$$GET1^DIQ(LRFILE,LRIENS,.01,"I")
+ I LRSS="AU" D
+ .S LRFILE=63.324,LRIENS1=LRDFN_","
+ .I '+$P($G(^LR(LRDFN,84,0)),"^",4) S LRNOSP=1 Q
+ .S LRX=0 F  S LRX=$O(^LR(LRDFN,84,LRX)) Q:'LRX  D
+ ..S LRIENS=LRX_","_LRIENS1
+ ..S LRSRFL=$$GET1^DIQ(LRFILE,LRIENS,.02,"I")
+ ..;LRSRMD-set to 1 if supp rpt modified and requires release
+ ..S LRSRMD=$$GET1^DIQ(LRFILE,LRIENS,.03,"I")
+ ..Q:LRSRFL&('LRSRMD)
+ ..S DIC("B")=$$GET1^DIQ(LRFILE,LRIENS,.01,"I")
+ I LRNOSP D  Q
+ .K LRMSG
+ .S LRMSG=$C(7)_"No supplementary reports exist for this accession."
+ .D EN^DDIOL(LRMSG,"","!!")
+ I 'DIC("B") D  Q
+ .K LRMSG
+ .S LRMSG=$C(7)_"All supplementary reports have been released."
+ .D EN^DDIOL(LRMSG,"","!!")
+DIE1 ;
+ S (LRQUIT,LRRLM)=0
+ F  D  Q:LRQUIT
+ .W !
+ .S:LRSS="AU" (LRLKFL,DIC)="^LR(LRDFN,84,"
+ .S:LRSS'="AU" (LRLKFL,DIC)="^LR(LRDFN,LRSS,LRI,1.2,"
+ .S DIC("A")="Select SUPPLEMENTARY REPORT DATE: "
+ .S DIC(0)="AEQM"
+ .D ^DIC K DIC
+ .I Y<1 S LRQUIT=1 Q
+ .S LRDA=+Y
+ .S LRIENS=LRDA_","_LRIENS1
+ .S LRRLS=+$$GET1^DIQ(LRFILE,LRIENS,.02,"I")
+ .;If E-Sign OFF, must check LRRLM.  LRRLM=1 if supp rpt has been
+ .;  modified and requires release
+ .S LRRLM=+$$GET1^DIQ(LRFILE,LRIENS,.03,"I")
+ .I LRESSW,LRRLS D  Q
+ ..W !!,"This supplementary report has already been released.",!
+ .I 'LRESSW,LRRLS D  Q:'LRRLM
+ ..I 'LRRLM W !!,"This supplementary rept has already been released.",!
+ .W !
+ .I LRESSW D  Q
+ ..D ESIG Q:LRQUIT
+ ..D UPDATE
+ .S DIR("A")="Release supplementary report",DIR(0)="Y",DIR("B")="NO"
+ .D ^DIR K DIR
+ .Q:'Y
+ .D UPDATE
+ .;If E-sign switch OFF and orig report released, must verify all
+ .;  supp reports released before release main report.
+ .I LRCKREL,'LRESSW D CHKSUP^LRAPR1
+ Q
+ ;
+A D ^LRAP G:'$D(Y) END
+ Q
+C ;
+ S LRDICS="SPCYEM" D ^LRAP
+ G:'$D(Y) END
+ Q
+S ;from LRAPDA
+ S LRK=$P(^LR(LRDFN,LRSS,LRI,0),"^",11) Q:'LRK  S:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)) ^(0)="^68.04PA^^"
+ Q:$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0))  S ^(0)=LRT_"^50^^"_DUZ_"^"_LRK,X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),^(0)=$P(X,"^",1,2)_"^"_LRT_"^"_($P(X,"^",4)+1)
+ S:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0)) ^(0)="^68.14P^^"
+ S C=0 F  S C=$O(LRT(C)) Q:'C  D CAP
+ S ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_LRT)=""
+ Q
+ ;
+CAP S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,C,0)=C_"^1^0^0^^"_LRK_"^"_DUZ_"^"_DUZ(2)_"^"_LRAA_"^"_LRAA_"^"_LRAA
+ S X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0),^(0)=$P(X,"^",1,2)_"^"_C_"^"_($P(X,"^",4)+1)
+ Q
+ ;
+SWITCH ;Check to see if electronic signature is enabled
+ D GETDATA^LRAPESON(.LRESSW)
+ Q
+ESIG ;Prompt for electronic signature
+ S LRQUIT=0
+ D SIG^XUSESIG
+ I X1="" D
+ .W "  SIGNATURE NOT VERIFIED"
+ .S LRQUIT=1
+ Q
+UPDATE ;
+ S LRLKFL=LRLKFL_LRDA_",0)"
+ L +@(LRLKFL):5 I '$T D  Q
+ .S LRMSG="This record is locked by another user.  "
+ .S LRMSG=LRMSG_"Please wait and try again."
+ .D EN^DDIOL(LRMSG,"","!!")
+ S LRFDA(LRFILE,LRIENS,.02)=1
+ S LRFDA2(LRFILE,LRIENS,.02)="@" ;Set but don't file unless unrel needed
+ ;File signer ID and Date/time of released supp report
+ D CKSIGNR^LRAPR1
+ D FILE^DIE("","LRFDA")
+ W "...Released"
+ L -@(LRLKFL)
+ ;If all supp reports released, and E-Sign switch is ON, proceed to
+ ;  release main report
+ S LRCKREL=0
+ S:LRSS'="AU" LRCKREL=$P(^LR(LRDFN,LRSS,LRI,0),"^",11)
+ S:LRSS="AU" LRCKREL=$P(^LR(LRDFN,LRSS),"^",15)
+ I LRCKREL,LRESSW D RELMN
+ Q
+SUPCHK ;Check for unreleased supplementary reports
+ N LRSR,LRSR1,LRSR2
+ S LRSR=0,LRSR1=1
+ I LRSS'="AU" D
+ .Q:'+$P($G(^LR(LRDFN,LRSS,LRI,1.2,0)),U,4)
+ .F  S LRSR=$O(^LR(LRDFN,LRSS,LRI,1.2,LRSR)) Q:LRSR'>0!('LRSR1)  D
+ ..S LRSR1=+$P(^LR(LRDFN,LRSS,LRI,1.2,LRSR,0),U,2)
+ ..I 'LRSR1 D
+ ...S Y=+$P(^LR(LRDFN,LRSS,LRI,1.2,LRSR,0),U)
+ ...D DD^%DT S LRSR2=Y
+ I LRSS="AU" D
+ .Q:'+$P($G(^LR(LRDFN,84,0)),U,4)
+ .F  S LRSR=$O(^LR(LRDFN,84,LRSR)) Q:LRSR'>0!('LRSR1)  D
+ ..S LRSR1=+$P(^LR(LRDFN,84,LRSR,0),U,2)
+ ..I 'LRSR1 D
+ ...S Y=+$P(^LR(LRDFN,84,LRSR,0),U)
+ ...D DD^%DT S LRSR2=Y
+ I 'LRSR1 D
+ .W $C(7),!,"Supplementary report "_LRSR2_" has not been released.  "
+ .W "Cannot release."
+ .S Y=0
+ Q
+RINFO ;Display release information
+ W $C(7),!,"Report "
+ W:LRZ(2)=1 "has already been "
+ W "released "
+ S Y=LRZ(2)
+ D DD^%DT
+ W:LRZ(2)>1 Y
+ W:LRZ(1)'="" " by "_$P($G(^VA(200,LRZ(1),0)),U)
+ K Y
+ Q
+NMPATH ;Check for missing pathologist name
+ I 'LRZ(3) D
+ .W $C(7),!,"Pathologist name missing.  Cannot release."
+ .S Y=0
+ Q
+RELEASE ;Prompt for release/unrelease
+ W ! S DIR(0)="YA",DIR("B")="NO"
+ S:LRZ(2) DIR("A")="Unrelease report? "
+ S:'LRZ(2) DIR("A")="Release report? "
+ D ^DIR
+ K:Y Y
+ I $D(Y) S Y=0
+ Q
+RELMN ;Allow release of main report as long as all supp reports are
+ ;  released, and signer is same person for main and supp report(s)
+ ;Make sure all supp reports signed out
+ S LRQT=0
+ D RELCHK^LRAPR1
+ Q:LRQT
+ ;
+ ;Continue with electronic signature and storage in TIU
+ S LRAU=$S(LRSS="AU":1,1:0)
+ I 'LRAU D
+ .S LRPAT=+$$GET1^DIQ(LRSF,LRIENS1,.02,"I")
+ .S LRZ=$$GET1^DIQ(LRSF,LRIENS1,.03,"I")
+ .S LRZ(1)=$$GET1^DIQ(LRSF,LRIENS1,.13,"I")
+ .S LRZ(1.1)=$$GET1^DIQ(LRSF,LRIENS1,.13)
+ .S LRZ(2)=$$GET1^DIQ(LRSF,LRIENS1,.11,"I")
+ I LRAU D
+ .S LRPAT=+$$GET1^DIQ(63,LRDFN_",",13.6,"I")
+ .S LRZ=$$GET1^DIQ(63,LRDFN_",",13,"I")
+ .S LRZ(1)=$$GET1^DIQ(63,LRDFN_",",14.8,"I")
+ .S LRZ(1.1)=$$GET1^DIQ(63,LRDFN_",",14.8)
+ .S LRZ(2)=$$GET1^DIQ(63,LRDFN_",",14.7,"I")
+ .S LRI=""
+ W !!,?25,"*** Main Report Release ***",!
+ D NOW^%DTC S LRNTIME=%
+ D TIUPREP^LRAPRES
+ D STORE^LRAPRES
+ I LRQUIT D FILE^DIE("","LRFDA2") Q
+ D UNRLSE^LRAPR1
+ D RELEASE^LRAPRES
+ I LRQUIT D FILE^DIE("","LRFDA2") Q
+ D MAIN^LRAPRES1(LRDFN,LRSS,LRI,LRSF,LRP,LRAC)
+ D OERR^LR7OB63D
+ S LRQUIT=1
+ Q
+END ;
+ D V^LRU
+ Q

WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRAPRES1.m

-              r613
+              r623
 LRAPRES1        ;DALOI/WTY/KLL/CKA - AP ESIG RELEASE REPORT/ALERT;11/13/01
+        ;;5.2;LAB SERVICE;**259,336,369,365**;Sep 27, 1994;Build 9
+        ;
         ;Reference to FILE^TIUSRVP supported by IA #3540
         ;Reference to ^TIULQ supported by IA #2693
+        ;Reference to ^ORB3LAB supported by IA #4287
+        ;Reference to DIC lookup on MAIL GROUP file (#3.8) supported by IA #10111
+        ;
+MAIN(LRDFN,LRSS,LRI,LRSF,LRP,LRAC)      ;Main subroutine
+        Q:'$D(LRDFN)!('$D(LRSS))!('$D(LRP))!('$D(LRAC))
+        N LRDOCS,LRMSG,LRC,LRDOCSN,LRNUM,LRADL,LRMORE,LRQUIT,LRXQA
+        N DIR,DIRUT,DTOUT,DUOUT,X,Y,DIC,XQA,XQAMSG
+        S LRQUIT=0
+        I $G(LRAU) D
+        .S LRA=^LR(LRDFN,"AU")
+        .S LRI=$P(LRA,U)
+        D DOCS
+        Q:LRQUIT
+        D MORE
+        I LRMORE D LOOKUP
+        D SEND
+        Q
+DOCS    ;GET ORDERING PROVIDER AND PCP TO SEND ALERT
+        W !
+        S:$G(LRSF)="" LRSF=63
+        D GETDOCS^LRAPUTL(.LRDOCS,LRDFN,LRSS,$G(LRI),LRSF)
+        S:LRDOCS(1)=LRDOCS(2) LRDOCS(2)=0
+        F LRC=1:1:2 D
+        .I LRDOCS(LRC) D
+        ..S LRDOCSN(LRC)=$$NAME^XUSER(LRDOCS(LRC),"F")
+        ..I LRDOCSN(LRC)'="" S LRXQA(LRDOCS(LRC))=""
+        S LRNUM=1
+        K LRMSG
+        D
+        .S LRMSG(LRNUM)="Alert will be sent to:",LRMSG(LRNUM,"F")="!!"
+        .I LRDOCS(1) D
+        ..S LRNUM=LRNUM+1,LRMSG(LRNUM)=LRDOCSN(1),LRMSG(LRNUM,"F")="?24"
         .I LRDOCS(2) D
+        ..S LRNUM=LRNUM+1,LRMSG(LRNUM)=LRDOCSN(2)
+        ..S LRMSG(LRNUM,"F")=$S(LRDOCS(1):"!",1:"")_"?24"
+        I LRQUIT D
+        .S LRMSG(LRNUM)="No Ordering Provider or PCP for alert"
+        .S LRMSG(LRNUM,"F")="!!"
+        D EN^DDIOL(.LRMSG)
+        Q
+MORE    ;Add names or mail groups to the lookup list?
+        N DIR,DIRUT,DTOUT,DUOUT,X,Y
+        W !
+        S LRMORE=1
+        S DIR(0)="Y"
+        S DIR("A")="Send the alert to additional names or mail groups"
+        S X=$$GET^XPAR("USR^DIV^PKG","LRAPRES1 AP ALERT",1,"Q")
+        S X=$S(X=1:"YES",X=0:"NO",1:"NO")
+        S DIR("B")=X
+        D ^DIR
+        I Y=0 S LRMORE=0 Q
+        I $D(DUOUT)!($D(DTOUT)) S LRQUIT=1,LRMORE=0
+        Q
+LOOKUP  ;Add additional names or mail groups to alert list.
+        F  D  Q:LRQUIT
+        .W !
+        .K DIR
+        .;S DIR(0)="F^3:30^I X'?1""U."".E&(X'?1""G."".E) K X"
         .S DIR(0)="FO^3:30^I X["".""&((X'?1""G."".E)&(X'?1""g."".E)) K X"
         .S DIR("A")="Enter name or mail group"
         .S DIR("?")="Enter lastname,firstname OR G.mailgroup OR ^ to exit"
+        .D ^DIR
+        .I $D(DIRUT) S LRQUIT=1 Q
+        .S X=Y,LRADL=""
+        .I Y["." S LRADL=$P(Y,"."),X=$P(Y,".",2)
         .S Y=$$UP^XLFSTR(Y)
+        .I LRADL="g" S LRADL="G"
+        .K DIC
+        .S DIC(0)="QEZ"
+        .S DIC=$S(LRADL="G":3.8,1:200)
+        .D ^DIC
+        .Q:Y=-1
         .S:LRADL="" XQA($P(Y,"^"))=""
+        .S:LRADL="G" XQA("G."_$P(Y,"^",2))=""
+        Q
+SEND    ;Send the alert
+        ;S XQAMSG=$E(LRP,1,9)_" ("_$E(LRP,1)_VA("BID")_"): Pathology report signed for "_LRAC_"."
+        ;D SETUP^XQALERT
+        M XQA=LRXQA
         D LAB^ORB3LAB(DFN,LRDFN,LRI,$G(LRA),LRSS,.XQA)
+        I $D(LRADL) D
         .S LRMSG="Alerts have been sent to the specified additional users."
         .D EN^DDIOL(LRMSG,"","!!")
         .K LRMSG
+        Q
 AHELP   ;Help Frame
         K LRMSG
         S LRMSG(1)="If answered 'Yes', the alert will notify the primary care"
         S LRMSG(1,"F")="!"
         S LRMSG(2)="provider and the surgeon/physician that this report has"
         S LRMSG(3)="been electronically signed and is now available for"
         S LRMSG(4)="viewing. You will also have the opportunity to send the"
         S LRMSG(5)="alert to additional names or mail groups."
         D EN^DDIOL(.LRMSG)
+        Q
 RETRACT(LRDFN,LRSS,LRI,LRTIUPTR)        ;
         ;Change prior TIU versions of report to RETRACTED status
         N LRROOT,LRIENS,LRFILE,LRTIUP,LRTIUAR,LRERR,LRSTAT,LRTIUX,LREXRR
         I LRSS=""!("AUSPEMCY"'[LRSS) S LRPTR=0 Q
         I LRSS="AU" D
         .S LRROOT="^LR(LRDFN,101,""C""",LRIENS=LRDFN_","
         .S LRFILE=63.101
         I LRSS'="AU" D
         .S LRROOT="^LR(LRDFN,LRSS,LRI,.05,""C"""
         .S LRIENS=LRI_","_LRDFN_","
         .S LRFILE=$S(LRSS="SP":63.19,LRSS="CY":63.47,LRSS="EM":63.49,1:"")
         Q:'$D(@(LRROOT_")"))
         S LRTIUP=0,LRTIUX(.05)=15
         F  S LRTIUP=$O(@(LRROOT_",LRTIUP)"))  Q:LRTIUP'>0!(LRTIUP=LRTIUPTR)  D
         .K LRTIUAR S (LRSTAT,LRERR)=0
         .D EXTRACT^TIULQ(LRTIUP,"LRTIUAR",.LRERR,".05",,,"I")
         .Q:+LRERR
         .M LRSTAT=LRTIUAR(LRTIUP,.05,"I")
         .Q:LRSTAT'=7  ;Quit if current status is not COMPLETED
         .D FILE^TIUSRVP(.LREXRR,LRTIUP,.LRTIUX)
         .;Update new TIU version of report with previous TIU pointer value
         .N LREXRR,LRTIUX
         .S LRTIUX(1406)=LRTIUP
         .D FILE^TIUSRVP(.LREXRR,LRTIUPTR,.LRTIUX)
+        Q
 CLSSCHK(DUZ,LREND)      ;Determine if user has the proper class settings and
         ;PROVIDER key
         N LRMSG,LRPRCLSS,LRPCEXP,LRVCDE,LRPCSTR,LRMTCH
         ;First, check for PROVIDER key
         I '$D(^XUSEC("PROVIDER",DUZ)) D  Q
         .K LRMSG S LRMSG=$C(7)_"Electronic signature not authorized.  Missing "
         .S LRMSG=LRMSG_"PROVIDER key."
         .D EN^DDIOL(LRMSG,"","!!")
         .K LRMSG S LREND=1
         ;Next, check the provider class
         S LRPRCLSS=$$GET1^DIQ(200,DUZ_",",53.5)
         ;PROVIDER CL MUST CONTAIN PHYSICIAN, OR CYTOTECH ONLY FOR CY SECTION
         ;OR DENTIST FOR ORAL AND MAXILLOFACIAL PATHOLOGY
         S LRMTCH=0
         I LRPRCLSS'["PHYSICIAN",LRPRCLSS'["DENTIST" D
         .I LRPRCLSS'["CYTOTECH" S LRMTCH=1
         .I LRSS'="CY" S LRMTCH=1
         I LRMTCH=1 D  Q
         .K LRMSG
         .S LRMSG(1)=$C(7)_"You are not authorized to electronically sign "
         .S LRMSG(1)=LRMSG(1)_"reports."
         .S LRMSG(1,"F")="!!"
         .S LRMSG(2)="PROVIDER CLASS must include PHYSICIAN,"
         .S LRMSG(2,"F")="!"
         .S LRMSG(3)="  OR CYTOTECHNOLOGIST FOR CY SECTIONS ONLY,"
         .S LRMSG(3,"F")="!"
         .S LRMSG(4)=" OR DENTIST FOR ORAL AND MAXILLOFACIAL PATHOLOGY."
         .S LRMSG(4,"F")="!"
         .D EN^DDIOL(.LRMSG) K LRMSG
         .S LREND=1
         ;Finally, check the person class
         S LRPCSTR=$$GET^XUA4A72(DUZ)   ;Supported reference #1625
         I LRPCSTR<0 D  Q
         .K LRMSG
         .S LRMSG="PERSON CLASS is inactive or undefined.  Electronic signature"
         .S LRMSG=LRMSG_" is not authorized."
         .D EN^DDIOL(LRMSG,"","!!")
         .K LRMSG
         .S LREND=1
         S LRPCEXP=+$P(LRPCSTR,"^",6)
         I LRPCEXP D  Q
         .K LRMSG
         .S LRMSG="PERSON CLASS has expired.  Electronic signature"
         .S LRMSG=LRMSG_" is not authorized."
         .D EN^DDIOL(LRMSG,"","!!") K LRMSG
         .S LREND=1
         S LRVCDE=$P(LRPCSTR,"^",7),LRMTCH=0
         ;CORRECT PERSON CLASS SHOULD MATCH PROVIDER CLASS
         I LRPRCLSS["PHYSICIAN" D
         .I $E(LRVCDE,1,6)="V11370","123568"[+$E(LRVCDE,7) S LRMTCH=1
         .I $E(LRVCDE,1,6)="V11371","03"[+$E(LRVCDE,7) S LRMTCH=1
         .I $E(LRVCDE,1,6)="V18240","124579"[+$E(LRVCDE,7) S LRMTCH=1
         .I LRVCDE="V182413" S LRMTCH=1
         I LRPRCLSS["CYTOTECH" D
         .I LRVCDE="V150113" S LRMTCH=1
         I LRPRCLSS["DENTIST" D
         .I LRVCDE="V030503" S LRMTCH=1
         I 'LRMTCH D
         .K LRMSG
         .S LRMSG="Invalid PERSON CLASS.  Electronic Signature is not "
         .S LRMSG=LRMSG_"authorized."
         .D EN^DDIOL(LRMSG,"","!!")
         .K LRMSG
         .S LREND=1
+        Q
+LRAPRES1 ;DALOI/WTY/KLL - AP ESIG RELEASE REPORT/ALERT;11/13/01
+ ;;5.2;LAB SERVICE;**259,336,369**;Sep 27, 1994;Build 2
+ ;
+ ;Reference  to FILE^TIUSRVP supported by IA #3540
+ ;Reference  to ^TIULQ supported by IA #2693
+ ;
+MAIN(LRDFN,LRSS,LRI,LRSF,LRP,LRAC) ;Main subroutine
+ Q:'$D(LRDFN)!('$D(LRSS))!('$D(LRP))!('$D(LRAC))
+ N LRDOCS,LRMSG,XQA,LRC,LRDOCSN,LRNUM,LRADL,LRMORE,LRQUIT
+ N DIR,DIRUT,DTOUT,DUOUT,X,Y,DIC,XQA,XQAMSG
+ S LRQUIT=0
+ D ASK
+ Q:LRQUIT
+ D MORE
+ Q:LRQUIT
+ D:LRMORE LOOKUP
+ D ALERT
+ Q
+ASK ;Ask if alert is to be sent
+ W !
+ S DIR(0)="Y",DIR("B")="NO"
+ S DIR("A")="Do you wish to send an alert"
+ S DIR("??")="^D AHELP^LRAPRES1"
+ D ^DIR
+ I 'Y S LRQUIT=1 Q
+ S:$G(LRSF)="" LRSF=63
+ D GETDOCS^LRAPUTL(.LRDOCS,LRDFN,LRSS,$G(LRI),LRSF)
+ S:LRDOCS(1)=LRDOCS(2) LRDOCS(2)=0
+ S LRQUIT=1
+ F LRC=1:1:2 D
+ .I LRDOCS(LRC) D
+ ..S LRQUIT=0
+ ..S X=LRDOCS(LRC) D D^LRUA S LRDOCSN(LRC)=X
+ ..I LRDOCSN(LRC)'="" S XQA(LRDOCS(LRC))=""
+ ;Q:LRQUIT
+ S LRNUM=1
+ K LRMSG
+ I 'LRQUIT D
+ .S LRMSG(LRNUM)="Alert will be sent to:",LRMSG(LRNUM,"F")="!!"
+ .I LRDOCS(1) D
+ ..S LRNUM=LRNUM+1,LRMSG(LRNUM)=LRDOCSN(1),LRMSG(LRNUM,"F")="?24"
+ .I LRDOCS(2) D
+ ..S LRNUM=LRNUM+1,LRMSG(LRNUM)=LRDOCSN(2)
+ ..S LRMSG(LRNUM,"F")=$S(LRDOCS(1):"!",1:"")_"?24"
+ I LRQUIT D
+ .S LRMSG(LRNUM)="No Physician or PCP selected for alert"
+ .S LRMSG(LRNUM,"F")="!!"
+ .S LRQUIT=0
+ D EN^DDIOL(.LRMSG)
+ Q
+MORE ;Add names or mail groups to the lookup list?
+ W !
+ S LRMORE=1
+ S DIR(0)="Y",DIR("B")="NO"
+ S DIR("A")="Send the alert to additional names or mail groups"
+ D ^DIR
+ I Y=0 S LRMORE=0 Q
+ I $D(DUOUT)!($D(DTOUT)) S LRQUIT=1
+ Q
+LOOKUP ;Add additional names or mail groups to alert list.
+ F  D  Q:LRQUIT
+ .W !
+ .K DIR
+ .;S DIR(0)="F^3:30^I X'?1""U."".E&(X'?1""G."".E) K X"
+ .S DIR(0)="F^3:30^I X["".""&(X'?1""G."".E) K X"
+ .S DIR("A")="Enter name or mail group"
+ .S DIR("?")="Enter lastname,firstname OR G.mailgroup OR ^ to exit"
+ .D ^DIR
+ .I $D(DUOUT)!($D(DTOUT)) S LRQUIT=1 Q
+ .S X=Y,LRADL=""
+ .I Y["." S LRADL=$P(Y,"."),X=$P(Y,".",2)
+ .K DIC
+ .S DIC(0)="QEZ"
+ .S DIC=$S(LRADL="G":3.8,1:200)
+ .D ^DIC
+ .Q:Y=-1
+ .S:LRADL="" XQA($P(Y,"^"))=""
+ .S:LRADL="G" XQA("G."_$P(Y,"^",2))=""
+ .K LRMSG
+ .S LRMSG=$S(LRADL="G":"Mail group ",1:"User ")_$P(Y,"^",2)
+ .S LRMSG=LRMSG_" added to alert list."
+ .D EN^DDIOL(LRMSG,"","!!")
+ Q
+ALERT ;Send the alert
+ S XQAMSG="Pathology report signed for "_LRAC_" - "_$E(LRP,1,30)
+ D SETUP^XQALERT
+ S LRMSG="Alerts have been sent."
+ D EN^DDIOL(LRMSG,"","!!")
+ K LRMSG
+ Q
+AHELP ;Help Frame
+ K LRMSG
+ S LRMSG(1)="If answered 'Yes', the alert will notify the primary care"
+ S LRMSG(1,"F")="!"
+ S LRMSG(2)="provider  and  the surgeon/physician that this report has"
+ S LRMSG(3)="been  electronically  signed  and  is  now  available for"
+ S LRMSG(4)="viewing.   You will also have the opportunity to send the"
+ S LRMSG(5)="alert to additional names or mail groups."
+ D EN^DDIOL(.LRMSG)
+ Q
+RETRACT(LRDFN,LRSS,LRI,LRTIUPTR) ;
+ ;Change prior TIU versions of report to RETRACTED status
+ N LRROOT,LRIENS,LRFILE,LRTIUP,LRTIUAR,LRERR,LRSTAT,LRTIUX,LREXRR
+ I LRSS=""!("AUSPEMCY"'[LRSS) S LRPTR=0 Q
+ I LRSS="AU" D
+ .S LRROOT="^LR(LRDFN,101,""C""",LRIENS=LRDFN_","
+ .S LRFILE=63.101
+ I LRSS'="AU" D
+ .S LRROOT="^LR(LRDFN,LRSS,LRI,.05,""C"""
+ .S LRIENS=LRI_","_LRDFN_","
+ .S LRFILE=$S(LRSS="SP":63.19,LRSS="CY":63.47,LRSS="EM":63.49,1:"")
+ Q:'$D(@(LRROOT_")"))
+ S LRTIUP=0,LRTIUX(.05)=15
+ F  S LRTIUP=$O(@(LRROOT_",LRTIUP)"))  Q:LRTIUP'>0!(LRTIUP=LRTIUPTR)  D
+ .K LRTIUAR S (LRSTAT,LRERR)=0
+ .D EXTRACT^TIULQ(LRTIUP,"LRTIUAR",.LRERR,".05",,,"I")
+ .Q:+LRERR
+ .M LRSTAT=LRTIUAR(LRTIUP,.05,"I")
+ .Q:LRSTAT'=7  ;Quit if current status is not COMPLETED
+ .D FILE^TIUSRVP(.LREXRR,LRTIUP,.LRTIUX)
+ .;Update new TIU version of report with previous TIU pointer value
+ .N LREXRR,LRTIUX
+ .S LRTIUX(1406)=LRTIUP
+ .D FILE^TIUSRVP(.LREXRR,LRTIUPTR,.LRTIUX)
+ Q
+CLSSCHK(DUZ,LREND) ;Determine if user has the proper class settings and
+ ;PROVIDER key
+ N LRMSG,LRPRCLSS,LRPCEXP,LRVCDE,LRPCSTR,LRMTCH
+ ;First, check for PROVIDER key
+ I '$D(^XUSEC("PROVIDER",DUZ)) D  Q
+ .K LRMSG S LRMSG=$C(7)_"Electronic signature not authorized.  Missing "
+ .S LRMSG=LRMSG_"PROVIDER key."
+ .D EN^DDIOL(LRMSG,"","!!")
+ .K LRMSG S LREND=1
+ ;Next, check the provider class
+ S LRPRCLSS=$$GET1^DIQ(200,DUZ_",",53.5)
+ ;PROVIDER CL MUST CONTAIN PHYSICIAN, OR CYTOTECH ONLY FOR CY SECTION
+ ;OR DENTIST FOR ORAL AND MAXILLOFACIAL PATHOLOGY
+ S LRMTCH=0
+ I LRPRCLSS'["PHYSICIAN",LRPRCLSS'["DENTIST" D
+ .I LRPRCLSS'["CYTOTECH" S LRMTCH=1
+ .I LRSS'="CY" S LRMTCH=1
+ I LRMTCH=1 D  Q
+ .K LRMSG
+ .S LRMSG(1)=$C(7)_"You are not authorized to electronically sign "
+ .S LRMSG(1)=LRMSG(1)_"reports."
+ .S LRMSG(1,"F")="!!"
+ .S LRMSG(2)="PROVIDER CLASS must include PHYSICIAN,"
+ .S LRMSG(2,"F")="!"
+ .S LRMSG(3)="  OR CYTOTECHNOLOGIST FOR CY SECTIONS ONLY,"
+ .S LRMSG(3,"F")="!"
+ .S LRMSG(4)=" OR DENTIST FOR ORAL AND MAXILLOFACIAL PATHOLOGY."
+ .S LRMSG(4,"F")="!"
+ .D EN^DDIOL(.LRMSG) K LRMSG
+ .S LREND=1
+ ;Finally, check the person class
+ S LRPCSTR=$$GET^XUA4A72(DUZ)   ;Supported reference #1625
+ I LRPCSTR<0 D  Q
+ .K LRMSG
+ .S LRMSG="PERSON CLASS is inactive or undefined.  Electronic signature"
+ .S LRMSG=LRMSG_" is not authorized."
+ .D EN^DDIOL(LRMSG,"","!!")
+ .K LRMSG
+ .S LREND=1
+ S LRPCEXP=+$P(LRPCSTR,"^",6)
+ I LRPCEXP D  Q
+ .K LRMSG
+ .S LRMSG="PERSON CLASS has expired.  Electronic signature"
+ .S LRMSG=LRMSG_" is not authorized."
+ .D EN^DDIOL(LRMSG,"","!!") K LRMSG
+ .S LREND=1
+ S LRVCDE=$P(LRPCSTR,"^",7),LRMTCH=0
+ ;CORRECT PERSON CLASS SHOULD MATCH PROVIDER CLASS
+ I LRPRCLSS["PHYSICIAN" D
+ .I $E(LRVCDE,1,6)="V11370","123568"[+$E(LRVCDE,7) S LRMTCH=1
+ .I $E(LRVCDE,1,6)="V11371","03"[+$E(LRVCDE,7) S LRMTCH=1
+ .I $E(LRVCDE,1,6)="V18240","124579"[+$E(LRVCDE,7) S LRMTCH=1
+ .I LRVCDE="V182413" S LRMTCH=1
+ I LRPRCLSS["CYTOTECH" D
+ .I LRVCDE="V150113" S LRMTCH=1
+ I LRPRCLSS["DENTIST" D
+ .I LRVCDE="V030503" S LRMTCH=1
+ I 'LRMTCH D
+ .K LRMSG
+ .S LRMSG="Invalid PERSON CLASS.  Electronic Signature is not "
+ .S LRMSG=LRMSG_"authorized."
+ .D EN^DDIOL(LRMSG,"","!!")
+ .K LRMSG
+ .S LREND=1
+ Q

WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRSPT.m

-              r613
+              r623
 LRSPT   ;AVAMC/REG/WTY - AP PRELIMINARY REPORTS ;10/16/01
+        ;;5.2;LAB SERVICE;**1,72,248,259,373**;Sep 27, 1994;Build 1
+        ;
         ;Reference to ^%DT supported by IA #10003
         ;Reference to ^DPT supported by IA #918
         ;Reference to ^DIWP suppported by IA #10011
         ;Reference to ^DIWW suppported by IA #10029
         ;Reference to EN^DDIOL supported by IA #10142
+        ;
         S X="T",%DT="" D ^%DT,D^LRU S LRTOD=Y D EN2^LRUA
         W !!,"Preliminary reports for ",LRO(68)
         G END:LRAPX=2,SGL:LRAPX=3,CH:LRAPX=4
 GETP    D EN1^LRUPS Q:LRAN=-1
         G:$D(^LRO(69.2,LRAA,1,LRAN,0)) GETP
         L +^LRO(69.2,LRAA,1):5  I '$T D  G GETP
         .S MSG(1)="The preliminary reports queue is in use by another person.  "
         .S MSG(1,"F")="!!"
         .S MSG(2)="You will need to add this accession to the queue later."
         .D EN^DDIOL(.MSG) K MSG
         S ^LRO(69.2,LRAA,1,LRAN,0)=LRDFN_"^"_LRI
         S X=^LRO(69.2,LRAA,1,0),^(0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1)
         L -^LRO(69.2,LRAA,1)
         G GETP
 CH      S LRAPX(1)=1 D EN^LRSPRPT2 Q:%<1
         W !!,"Save preliminary reports for reprinting "
         S %=2 D YN^LRU S:%=1 LRSAV=1
         ;Variable LR("DVD") is used to divide reports displayed in the browser
         K LR("DVD")
         S $P(LR("DVD"),"|",IOM)=""
 DEV     ;
         W !
         S %ZIS="Q" D ^%ZIS
         I POP W ! Q
         I $D(IO("Q")) D  Q
         .S ZTDESC="ANAT PATH PRELIM REPORT"
         .S ZTSAVE("LR*")="",ZTRTN="QUE^LRSPT"
         .D ^%ZTLOAD W:$D(ZTSK) !,"Request Queued, #",ZTSK W !
         .K ZTSK,IO("Q") D HOME^%ZIS
 QUE     ;
         U IO
         ;LRSF515=1 means this is generating and SF515.
         S:'$D(LRSF515) LRSF515=0
         D L^LRU,L1^LRU,S^LRU,SET^LRUA
         S LR("SPSM")=1  ;Set flag to suppress printing of SNOMED codes
         S LRS(5)=1,LRQ(2)=1,LRA=$S($D(^LRO(69.2,LRAA,0)):$P(^(0),U,9),1:1)
         S:LRA="" LRA=1
         S LR("DIWF")=$S($P(^LRO(69.2,LRAA,0),"^",6)="D":"D",1:"")_"W"
         I $D(LRAP) S LRDFN=$P(LRAP,"^"),LRI=$P(LRAP,"^",2) D D G K
         S LRAN=0 F  S LRAN=$O(^LRO(69.2,LRAA,1,LRAN)) Q:'LRAN!(LR("Q"))  D
         .S X=^LRO(69.2,LRAA,1,LRAN,0),LRDFN=+X,LRI=$P(X,"^",2) D D
         .W:IOST["BROWSER" !!,LR("DVD")
 K       K:'$D(LRSAV) ^LRO(69.2,LRAA,1) K P,S,LRAN
         S ^LRO(69.2,LRAA,1,0)="^69.21A^^"
         I 'LR("Q"),$D(LR("F")),IOST?1"C".E D CONT
         K LRSAV
         W:IOST?1"P-".E @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
         K %,DIR,DTOUT,DUOUT,DIRUT,X,Y
+        Q
 D       K ^UTILITY($J) I '$D(^LR(LRDFN,0)) K ^LRO(69.2,LRAA,1,LRAN) Q
         N LRPRE S LRPRE=1 ;Notifies EN^LRSPRPT that this is a prelim report
         D EN^LRSPRPT Q:LR("Q")
         I $P($G(^LR(LRDFN,0)),"^",2)=2 D  Q:LR("Q")
         .D ^LRAPPOW
         G:'$D(^LR(LRDFN,"SP",0))&('$D(^LR(LRDFN,"CY",0)))&('$D(^LR(LRDFN,"EM",0))) AU
         D ^LRAPT1 Q:LR("Q")
 AU      I $D(^LR(LRDFN,"AU")),$L($P(^LR(LRDFN,"AU"),"^")) D ^LRAPT2 Q:LR("Q")
         K ^UTILITY($J) S DIWR=IOM-5,DIWF="W",LR("A")=0
         W ! F LRZ=0:1 S LR("A")=$O(^LRO(69.2,LRAA,10,LR("A"))) Q:'LR("A")  D
         .D:$Y>(IOSL-13) F^LRAPF,H S X=^LRO(69.2,LRAA,10,LR("A"),0) D ^DIWP
         D:LRZ ^DIWW
         S LRO=1 D F^LRAPF
+        Q
 H       ;from LRAPPF1
         D F^LRU W !,"ANATOMIC PATHOLOGY",!,LR("%") Q
 END     W $C(7),!!,"OK TO DELETE THE ",LRO(68)," PRELIMINARY REPORT LIST" S %=2 D YN^LRU I %=1 K ^LRO(69.2,LRAA,1) S ^LRO(69.2,LRAA,1,0)="^69.21A^0^0" W $C(7),!,"LIST DELETED !" Q
         W !!,"FINE, LET'S FORGET IT",! Q
+        ;
 SGL     D EN1^LRUPS Q:LRAN=-1  S LRAP=LRDFN_"^"_LRI,LRSAV=1 D EN2^LRUA G DEV
 CONT    ;
         K DIR S DIR(0)="E"
         D ^DIR W !
         S:$D(DTOUT)!(X[U) LR("Q")=1
+        Q
+LRSPT ;AVAMC/REG/WTY - AP PRELIMINARY REPORTS ;10/16/01
+ ;;5.2;LAB SERVICE;**1,72,248,259**;Sep 27, 1994
+ ;
+ ;Reference to ^%DT supported by IA #10003
+ ;Reference to ^DPT supported by IA #918
+ ;Reference to ^DIWP suppported by IA #10011
+ ;Reference to ^DIWW suppported by IA #10029
+ ;Reference to EN^DDIOL supported by IA #10142
+ ;
+ S X="T",%DT="" D ^%DT,D^LRU S LRTOD=Y D EN2^LRUA
+ W !!,"Preliminary reports for ",LRO(68)
+ G END:LRAPX=2,SGL:LRAPX=3,CH:LRAPX=4
+GETP D EN1^LRUPS Q:LRAN=-1
+ G:$D(^LRO(69.2,LRAA,1,LRAN,0)) GETP
+ L +^LRO(69.2,LRAA,1):5  I '$T D  G GETP
+ .S MSG(1)="The preliminary reports queue is in use by another person.  "
+ .S MSG(1,"F")="!!"
+ .S MSG(2)="You will need to add this accession to the queue later."
+ .D EN^DDIOL(.MSG) K MSG
+ S ^LRO(69.2,LRAA,1,LRAN,0)=LRDFN_"^"_LRI
+ S X=^LRO(69.2,LRAA,1,0),^(0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1)
+ L -^LRO(69.2,LRAA,1)
+ G GETP
+CH S LRAPX(1)=1 D EN^LRSPRPT2 Q:%<1
+ W !!,"Save preliminary reports for reprinting "
+ S %=2 D YN^LRU S:%=1 LRSAV=1
+ ;Variable LR("DVD") is used to divide reports displayed in the browser
+ K LR("DVD")
+ S $P(LR("DVD"),"|",IOM)=""
+DEV ;
+ W !
+ S %ZIS="Q" D ^%ZIS
+ I POP W ! Q
+ I $D(IO("Q")) D  Q
+ .S ZTDESC="ANAT PATH PRELIM REPORT"
+ .S ZTSAVE("LR*")="",ZTRTN="QUE^LRSPT"
+ .D ^%ZTLOAD W:$D(ZTSK) !,"Request Queued, #",ZTSK W !
+ .K ZTSK,IO("Q") D HOME^%ZIS
+QUE ;
+ U IO
+ ;LRSF515=1 means this is generating and SF515.
+ S:'$D(LRSF515) LRSF515=0
+ D L^LRU,L1^LRU,S^LRU,SET^LRUA
+ S LR("SPSM")=1  ;Set flag to suppress printing of SNOMED codes
+ S LRS(5)=1,LRQ(2)=1,LRA=$S($D(^LRO(69.2,LRAA,0)):$P(^(0),U,9),1:1)
+ S:LRA="" LRA=1
+ S LR("DIWF")=$S($P(^LRO(69.2,LRAA,0),"^",6)="D":"D",1:"")_"W"
+ I $D(LRAP) S LRDFN=$P(LRAP,"^"),LRI=$P(LRAP,"^",2) D D G K
+ S LRAN=0 F  S LRAN=$O(^LRO(69.2,LRAA,1,LRAN)) Q:'LRAN!(LR("Q"))  D
+ .S X=^LRO(69.2,LRAA,1,LRAN,0),LRDFN=+X,LRI=$P(X,"^",2) D D
+ .W:IOST["BROWSER" !!,LR("DVD")
+K K:'$D(LRSAV) ^LRO(69.2,LRAA,1) K P,S,LRAN
+ S ^LRO(69.2,LRAA,1,0)="^69.21A^^"
+ I 'LR("Q"),$D(LR("F")),IOST?1"C".E D CONT
+ K LRSAV
+ W:IOST?1"P-".E @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
+ K %,DIR,DTOUT,DUOUT,DIRUT,X,Y
+ Q
+D K ^UTILITY($J) I '$D(^LR(LRDFN,0)) K ^LRO(69.2,LRAA,1,LRAN) Q
+ N LRPRE S LRPRE=1 ;Notifies EN^LRSPRPT that this is a prelim report
+ D EN^LRSPRPT Q:LR("Q")
+ I $P($G(^LR(LRDFN,0)),"^",2)=2 D  Q:LR("Q")
+ .D ^LRAPPOW
+ G:'$D(^LR(LRDFN,"SP",0))&('$D(^LR(LRDFN,"CY",0)))&('$D(^LR(LRDFN,"EM",0))) AU
+ D ^LRAPT1 Q:LR("Q")
+AU I $D(^LR(LRDFN,"AU")),$L($P(^LR(LRDFN,"AU"),"^")) D ^LRAPT2 Q:LR("Q")
+ K ^UTILITY($J) S DIWR=IOM-5,DIWF="W",LR("A")=0
+ W ! F LRZ=0:1 S LR("A")=$O(^LRO(69.2,LRAA,10,LR("A"))) Q:'LR("A")  D
+ .D:$Y>(IOSL-6) H S X=^LRO(69.2,LRAA,10,LR("A"),0) D ^DIWP
+ D:LRZ ^DIWW
+ S LRO=1 D F^LRAPF
+ Q
+H ;from LRAPPF1
+ D F^LRU W !,"ANATOMIC PATHOLOGY",!,LR("%") Q
+END W $C(7),!!,"OK TO DELETE THE ",LRO(68)," PRELIMINARY REPORT LIST" S %=2 D YN^LRU I %=1 K ^LRO(69.2,LRAA,1) S ^LRO(69.2,LRAA,1,0)="^69.21A^0^0" W $C(7),!,"LIST DELETED !" Q
+ W !!,"FINE, LET'S FORGET IT",! Q
+ ;
+SGL D EN1^LRUPS Q:LRAN=-1  S LRAP=LRDFN_"^"_LRI,LRSAV=1 D EN2^LRUA G DEV
+CONT ;
+ K DIR S DIR(0)="E"
+ D ^DIR W !
+ S:$D(DTOUT)!(X[U) LR("Q")=1
+ Q

WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRSRVR6.m

-              r613
+              r623
+LRSRVR6 ;DALIO/JMC - LAB DATA SERVER CONT'D SNOMED EXTRACT ;Aug 17, 2006
+        ;;5.2;LAB SERVICE;**346,378**;Sep 27, 1994;Build 1
+        ; Produces SNOMED extract via LRLABSERVER option
+        ;
+        Q
+        ;
+        ;
+SERVER  ; Server entry Point
+        N I,LRCNT,LREND,LRL,LRMSUBJ,LRST,LRSTN,LRTXT,LRX,LRY
+        D BUILD
+        S LRMSUBJ=LRST_" "_LRSTN_" SNOMED EXTRACT "_$$HTE^XLFDT($H,"1M")
+        D MAILSEND(LRMSUBJ)
+        D CLEAN
+        Q
+        ;
+        ;
+BUILD   ; Build extract
+        N J,LRCNT,LRCRLF,LRETIME,LRFN,LRLEX,LRNAME,LRQUIT,LRROOT,LRSCT,LRSCTEC,LRSCTVER,LRSCTX,LRSPEC,LRSTIME,LRSTR,LRVAL,LRVUID,LRX,LRY,X,Y
+        ;
+        S LRSTIME=$$NOW^XLFDT,LRVAL=$$SITE^VASITE,LRST=$P(LRVAL,"^",3),LRSTN=$P(LRVAL,"^",2),LRSCTVER=""
+        I LRST="" S LRST="???"
+        K ^TMP($J,"LRDATA")
+        S (LRCNT,LRCNT("SCT"))=0,LRCRLF=$C(13,10),LRSTR=""
+        F I=61,61.1,61.2,61.3,61.4,61.5,61.6,62 S LRCNT(I)=0,LRCNT(I,"SCT")=0
+        D HDR
+        ;
+        ; Flag to indicate if SNOMED CT is available from LEXICON.
+        S LRLEX=0
+        I $T(CODE^LEXTRAN)'="" S LRLEX=1
+        ;
+        F LRFN=61,61.1,61.2,61.3,61.4,61.5,61.6,62  D
+        . S LRROOT="^LAB("_LRFN_",""B"")"
+        . D FILE
+        ;
+        S LRETIME=$$NOW^XLFDT
+        ; Set the final info into the ^TMP message global
+        S LRNODE=$O(^TMP($J,"LRDATA",""),-1)
+        I LRSTR'="" S LRNODE=LRNODE+1,^TMP($J,"LRDATA",LRNODE)=$$UUEN^LRSRVR4(LRSTR)
+        S ^TMP($J,"LRDATA",LRNODE+1)=" "
+        S ^TMP($J,"LRDATA",LRNODE+2)="end"
+        ;
+        S ^TMP($J,"LRDATA",1)=^TMP($J,"LRDATA",1)_" (Run time:"_$$FMDIFF^XLFDT(LRETIME,LRSTIME,3)_")"
+        S ^TMP($J,"LRDATA",3)="SNOMED CT version......: "_LRSCTVER
+        S J=6
+        S ^TMP($J,"LRDATA",J)="Number of records per file:"
+        F I=61,61.1,61.2,61.3,61.4,61.5,61.6,62 D
+        . S J=J+1
+        . S ^TMP($J,"LRDATA",J)=" "_$$LJ^XLFSTR($$GET1^DID(I,"","","NAME")_" File (#"_I_")",32,".")_": "_$J(LRCNT(I),5)_"  ("_LRCNT(I,"SCT")_" mapped)"
+        S ^TMP($J,"LRDATA",J+1)=$$LJ^XLFSTR("Total number of records",33,".")_": "_$J(LRCNT,5)_"  ("_LRCNT("SCT")_" mapped)"
+        ;
+        Q
+        ;
+        ;
+CLEAN   ;
+        K ^TMP($J,"LR61")
+        K LRIEN,LRLEN,LRNODE,LRSNM,LRSPECN
+        D CLEAN^LRSRVR
+        D ^%ZISC
+        Q
+        ;
+        ;
+FILE    ; Search file entry and build record.
+        ;
+        F  S LRROOT=$Q(@LRROOT) Q:LRROOT=""  Q:$QS(LRROOT,2)'="B"  D
+        . Q:$G(@LRROOT)
+        . S LRIEN=$QS(LRROOT,4),LRSPEC=""
+        . S LRNAME=$P($G(^LAB(LRFN,LRIEN,0)),"^"),LRNAME=$$TRIM^XLFSTR(LRNAME,"RL"," ")
+        . S X=$P($G(^LAB(LRFN,LRIEN,0)),"^",2)
+        . S LRSNM=$S(LRFN'=62:X,1:"")
+        . I LRFN=62 S LRSPEC=X
+        . I LRSNM'="",LRFN>60.9,LRFN<61.61 S LRX=((LRFN*10)#610)+1,LRSNM=$E("TMEFDPJ",LRX)_"-"_LRSNM
+        . S LRSCT=$P($G(^LAB(LRFN,LRIEN,"SCT")),"^"),(LRSCTEC,LRSCTX,LRVUID)=""
+        . I LRLEX,LRSCT'="" D
+        . . K LRX
+        . . S LRX=$$CODE^LEXTRAN(LRSCT,"SCT",DT,"LRX")
+        . . S LRSCTX=$G(LRX("F")),LRSCTEC=$S(LRX<1:$P(LRX,"^",2),1:"")
+        . . I LRSCTVER="",LRX>0 S LRSCTVER=$P($G(LRX(0)),"^",3)
+        . S LRSTR=LRSTR_LRST_"-"_LRFN_"-"_LRIEN_"|"_LRNAME_"|"_LRSNM_"|"_LRVUID_"|"_LRSCT_"|"_LRSCTX_"|"_LRSCTEC_"|"
+        . S LRSPECN="|"
+        . I LRFN=62,LRSPEC D
+        . . S LRSPECN=$P($G(^LAB(61,LRSPEC,0)),"^")
+        . . S LRSPECN=LRSPECN_"|"_LRST_"-61-"_LRSPEC
+        . S LRSTR=LRSTR_LRSPECN_"|1.1|"
+        . S LRCNT=LRCNT+1,LRCNT(LRFN)=LRCNT(LRFN)+1 S:LRSCT LRCNT("SCT")=LRCNT("SCT")+1,LRCNT(LRFN,"SCT")=LRCNT(LRFN,"SCT")+1
+        . D SETDATA
+        Q
+        ;
+        ;
+SETDATA ; Set data into report structure
+        S LRSTR=LRSTR_LRCRLF
+        S LRNODE=$O(^TMP($J,"LRDATA",""),-1)
+        D ENCODE^LRSRVR4(.LRSTR)
+        Q
+        ;
+        ;
+HDR     ; Set the header information
+        N LRFILENM
+        S LRFILENM=$TR(LRSTN," ","_")_"-"_LRSUB_"-"_$P($$FMTHL7^XLFDT(LRSTIME),"-")_".TXT"
+        S ^TMP($J,"LRDATA",1)="Report Generated.......: "_$$FMTE^XLFDT(LRSTIME)_" at "_LRSTN
+        S ^TMP($J,"LRDATA",2)="Report requested.......: "_LRSUB
+        S ^TMP($J,"LRDATA",3)="SNOMED CT version......: "
+        S ^TMP($J,"LRDATA",4)="Extract version........: 1.1"
+        F I=5,15,16,18,23 S ^TMP($J,"LRDATA",I)=" "
+        S ^TMP($J,"LRDATA",17)="Attached file..........: "_LRFILENM
+        S ^TMP($J,"LRDATA",19)="Legend:"
+        S X="Station #-File #-IEN|Entry Name|SNOMED I|VUID|SNOMED CT|SNOMED CT TERM|Mapping Exception|Related Specimen|Related Specimen ID|Extract Ver|"
+        S ^TMP($J,"LRDATA",20)=X
+        S X="           1        |     2    |   3    |  4 |    5    |       6      |        7        |        8       |        9          |    10     |"
+        S ^TMP($J,"LRDATA",21)=X
+        S ^TMP($J,"LRDATA",22)=$$REPEAT^XLFSTR("-",$L(X))
+        S ^TMP($J,"LRDATA",24)=$$UUBEGFN^LRSRVR2A(LRFILENM)
+        Q
+        ;
+        ;
+MAILSEND(LRMSUBJ)       ; Send extract back to requestor.
+        ;
+        N LRINSTR,LRTASK,LRTO,XMERR,XMZ
+        S LRTO(XQSND)=""
+        S LRINSTR("ADDR FLAGS")="R"
+        S LRINSTR("FROM")="LAB_PACKAGE"
+        S LRMSUBJ=$E(LRMSUBJ,1,65)
+        D SENDMSG^XMXAPI(.5,LRMSUBJ,"^TMP($J,""LRDATA"")",.LRTO,.LRINSTR,.LRTASK)
+        Q
+LRSRVR6 ;DALIO/JMC - LAB DATA SERVER CONT'D SNOMED EXTRACT ;Aug 17, 2006
+ ;;5.2;LAB SERVICE;**346**;Sep 27, 1994;Build 10
+ ; Produces SNOMED extract via LRLABSERVER option
+ ;
+ Q
+ ;
+ ;
+SERVER ; Server entry Point
+ N I,LRCNT,LREND,LRL,LRMSUBJ,LRST,LRSTN,LRTXT,LRX,LRY
+ D BUILD
+ S LRMSUBJ=LRST_" "_LRSTN_" SNOMED EXTRACT "_$$HTE^XLFDT($H,"1M")
+ D MAILSEND(LRMSUBJ)
+ D CLEAN
+ Q
+ ;
+ ;
+BUILD ; Build extract
+ N J,LRCNT,LRCRLF,LRETIME,LRFN,LRLEX,LRNAME,LRQUIT,LRROOT,LRSCT,LRSCTEC,LRSCTVER,LRSCTX,LRSPEC,LRSTIME,LRSTR,LRVAL,LRVUID,LRX,LRY,X,Y
+ ;
+ S LRSTIME=$$NOW^XLFDT,LRVAL=$$SITE^VASITE,LRST=$P(LRVAL,"^",3),LRSTN=$P(LRVAL,"^",2),LRSCTVER=""
+ I LRST="" S LRST="???"
+ K ^TMP($J,"LRDATA")
+ S (LRCNT,LRCNT("SCT"))=0,LRCRLF=$C(13,10),LRSTR=""
+ F I=61,61.1,61.2,61.3,61.4,61.5,61.6,62 S LRCNT(I)=0,LRCNT(I,"SCT")=0
+ D HDR
+ ;
+ ; Flag to indicate if SNOMED CT is available from LEXICON.
+ S LRLEX=0
+ I $T(CODE^LEXTRAN)'="" S LRLEX=1
+ ;
+ F LRFN=61,61.1,61.2,61.3,61.4,61.5,61.6,62  D
+ . S LRROOT="^LAB("_LRFN_",""B"")"
+ . D FILE
+ ;
+ S LRETIME=$$NOW^XLFDT
+ ; Set the final info into the ^TMP message global
+ S LRNODE=$O(^TMP($J,"LRDATA",""),-1)
+ I LRSTR'="" S LRNODE=LRNODE+1,^TMP($J,"LRDATA",LRNODE)=$$UUEN^LRSRVR4(LRSTR)
+ S ^TMP($J,"LRDATA",LRNODE+1)=" "
+ S ^TMP($J,"LRDATA",LRNODE+2)="end"
+ ;
+ S ^TMP($J,"LRDATA",1)=^TMP($J,"LRDATA",1)_" (Run time:"_$$FMDIFF^XLFDT(LRETIME,LRSTIME,3)_")"
+ S ^TMP($J,"LRDATA",3)="SNOMED CT version......: "_LRSCTVER
+ S J=6
+ S ^TMP($J,"LRDATA",J)="Number of records per file:"
+ F I=61,61.1,61.2,61.3,61.4,61.5,61.6,62 D
+ . S J=J+1
+ . S ^TMP($J,"LRDATA",J)=" "_$$LJ^XLFSTR($$GET1^DID(I,"","","NAME")_" File (#"_I_")",32,".")_": "_$J(LRCNT(I),5)_"  ("_LRCNT(I,"SCT")_" mapped)"
+ S ^TMP($J,"LRDATA",J+1)=$$LJ^XLFSTR("Total number of records",33,".")_": "_$J(LRCNT,5)_"  ("_LRCNT("SCT")_" mapped)"
+ ;
+ Q
+ ;
+ ;
+CLEAN ;
+ K ^TMP($J,"LR61")
+ K LRIEN,LRLEN,LRNODE,LRSNM,LRSPECN
+ D CLEAN^LRSRVR
+ D ^%ZISC
+ Q
+ ;
+ ;
+FILE ; Search file entry and build record.
+ ;
+ F  S LRROOT=$Q(@LRROOT) Q:LRROOT=""  Q:$QS(LRROOT,2)'="B"  D
+ . Q:$G(@LRROOT)
+ . S LRIEN=$QS(LRROOT,4),LRSPEC=""
+ . S LRNAME=$P($G(^LAB(LRFN,LRIEN,0)),"^"),LRNAME=$$TRIM^XLFSTR(LRNAME,"RL"," ")
+ . S X=$P($G(^LAB(LRFN,LRIEN,0)),"^",2)
+ . S LRSNM=$S(LRFN'=62:X,1:"")
+ . I LRFN=62 S LRSPEC=X
+ . I LRSNM'="",LRFN>60.9,LRFN<61.61 S LRX=((LRFN*10)#610)+1,LRSNM=$E("TMEFDPJ",LRX)_"-"_LRSNM
+ . S LRSCT=$P($G(^LAB(LRFN,LRIEN,"SCT")),"^"),(LRSCTEC,LRSCTX,LRVUID)=""
+ . I LRLEX,LRSCT'="" D
+ . . K LRX
+ . . S LRX=$$CODE^LEXTRAN(LRSCT,"SCT",DT,"LRX")
+ . . S LRSCTX=$G(LRX("F")),LRSCTEC=$S(LRX<1:$P(LRX,"^",2),1:"")
+ . . I LRSCTVER="",LRX>0 S LRSCTVER=$P($G(LRX(0)),"^",3)
+ . S LRSTR=LRSTR_LRST_"-"_LRFN_"-"_LRIEN_"|"_LRNAME_"|"_LRSNM_"|"_LRVUID_"|"_LRSCT_"|"_LRSCTX_"|"_LRSCTEC_"|"
+ . S LRSPECN="|"
+ . I LRFN=62,LRSPEC D
+ . . S LRSPECN=$P($G(^LAB(61,LRSPEC,0)),"^")
+ . . S LRSPECN=LRSPECN_"|"_LRST_"-61-"_LRSPEC
+ . S LRSTR=LRSTR_LRSPECN_"|1.1|"
+ . S LRCNT=LRCNT+1,LRCNT(LRFN)=LRCNT(LRFN)+1 S:LRSCT LRCNT("SCT")=LRCNT("SCT")+1,LRCNT(LRFN,"SCT")=LRCNT(LRFN,"SCT")+1
+ . D SETDATA
+ Q
+ ;
+ ;
+SETDATA ; Set data into report structure
+ S LRSTR=LRSTR_LRCRLF
+ S LRNODE=$O(^TMP($J,"LRDATA",""),-1)
+ D ENCODE^LRSRVR4(.LRSTR)
+ Q
+ ;
+ ;
+HDR ; Set the header information
+ N LRFILENM
+ S LRFILENM=$TR(LRSTN," ","_")_"-"_LRSUB_"-"_$P($$FMTHL7^XLFDT(LRSTIME),"-")_".TXT"
+ S ^TMP($J,"LRDATA",1)="Report Generated.......: "_$$FMTE^XLFDT(LRSTIME)_" at "_LRSTN
+ S ^TMP($J,"LRDATA",2)="Report requested.......: "_LRSUB
+ S ^TMP($J,"LRDATA",3)="SNOMED CT version......: "
+ S ^TMP($J,"LRDATA",4)="Extract version........: 1.1"
+ F I=5,15,16,18,23 S ^TMP($J,"LRDATA",I)=" "
+ S ^TMP($J,"LRDATA",17)="Attached file..........: "_LRFILENM
+ S ^TMP($J,"LRDATA",19)="Legend:"
+ S X="Station #-File #-IEN|Entry Name|SNOMED I|VUID|SNOMED CT|SNOMED CT TERM|Mapping Exception|Related Specimen|Related Specimen ID|Extract Ver|"
+ S ^TMP($J,"LRDATA",20)=X
+ S X="           1        |     2    |   3    |  4 |    5    |       6      |        7        |        8       |        9          |    10     |"
+ S ^TMP($J,"LRDATA",21)=X
+ S ^TMP($J,"LRDATA",22)=$$REPEAT^XLFSTR("-",$L(X))
+ S ^TMP($J,"LRDATA",24)=$$UUBEGFN^LRSRVR2A(LRFILENM)
+ Q
+ ;
+ ;
+MAILSEND(LRMSUBJ) ; Send extract back to requestor.
+ ;
+ N LRINSTR,LRTASK,LRTO,XMERR,XMZ
+ S LRTO(XQSND)=""
+ S LRINSTR("ADDR FLAGS")="R"
+ S LRINSTR("FROM")="LAB_PACKAGE"
+ D SENDMSG^XMXAPI(.5,LRMSUBJ,"^TMP($J,""LRDATA"")",.LRTO,.LRINSTR,.LRTASK)
+ Q

WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRVER3A.m

-              r613
+              r623
 LRVER3A ;SLC/CJS/DALOI/FHS - DATA VERIFICATION ;5/27/03  14:49
+        ;;5.2;LAB SERVICE;**1,5,42,100,121,153,190,221,254,263,266,274,295,373**;Sep 27, 1994;Build 1
         ;Also contains LRORFLG to restrict multiple OERR alerts (VER+2)
         ; Reference to ^DIC(42 supported by IA #10039
         ; Reference to ^%ZTLOAD supported by DBIA #10063
         ; Reference to IN5^VADPT supported by DBIA #10061
         ; Reference to $$NOW^XLFDT supported by DBIA #10103
+        ;
 VER     ;Call with L ^LR(LRDFN,LRSS,LRIDT) from LRGV2, LRGVG1, LRSTUF1, LRSTUF2, LRVR3
         Q:'$O(LRSB(0))
         N LRVCHK,LRORTST,LRORFLG,LRT
         S LRORU3=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),(LRAOD,LRACD)=$P(^(0),U,3)
         S LRACD=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,9)):^(9),1:LRACD)
         S:'($D(^LRO(68,LRAA,1,LRACD,1,LRAN,0))#2) LRACD=LRAD
         S LRAOD=$S($D(^LRO(68,LRAA,1,LRAOD,1,LRAN,0))#2:LRAOD,1:LRAD)
         I '$G(LRFIX) S LRNOW=$$NOW^XLFDT,$P(^LR(LRDFN,LRSS,LRIDT,0),U,3,4)=LRNOW_U_$S($G(LRDUZ):LRDUZ,1:DUZ)
         K A2 I '$D(PNM) S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX S:PNM="" PNM="NONAME"
         N LRT S LRT=0 F  S LRT=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT)) Q:LRT<.5  S:$P(^(LRT,0),U,5)="" A2(LRT)=1 I $D(^TMP("LR",$J,"VTO",LRT)) S LRVCHK=+^(LRT) D
         . I $S(LRVCHK<1:1,$D(LRSB(LRVCHK))#2:1,1:0) D
         . . I $D(LRSB(LRVCHK)) Q:$P(LRSB(LRVCHK),U)=""
         . . I LRVCHK<1,$L($P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0),U,6)) Q
         . . D
         . . . S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0),U,4)=$S($G(LRDUZ):LRDUZ,$G(DUZ):DUZ,1:"")
         . . . S:'$P(^(0),U,5) $P(^(0),U,5)=LRNOW
         . . . S $P(^(0),U,6)="",$P(^(0),U,8)=$G(LRCDEF)
         . . S LRORTST(LRT)=""
         . . I LRACD'=LRAD D
         . . . Q:'$D(^LRO(68,LRAA,1,LRACD,1,LRAN,4,+LRT,0))  D
         . . . . S $P(^LRO(68,LRAA,1,LRACD,1,LRAN,4,+LRT,0),U,4)=$S($G(LRDUZ):LRDUZ,$G(DUZ):DUZ,1:"")
         . . . . S:'$P(^(0),U,5) $P(^(0),U,5)=LRNOW
         . . . . S $P(^(0),U,6)="",$P(^(0),U,8)=$G(LRCDEF)
         . . I $P($G(LRPARAM),U,14),$P($G(^LRO(68,+LRAA,0)),U,16) S ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_LRT)=""
         . . K A2(LRT)
         . . I +$G(LRDPF)=2,$$VER^LR7OU1<3 D
         . . . N I,Y
         . . . S Y=LRNOW,I=LRT D V^LROR ;OE/RR 2.5
         ;-K ZZCARE,ZRECORD I $D(^LR(LRDFN,.3)),^LR(LRDFN,.3)'="" D FCS  ; CJS/MPLS 12-4-91 LINK TO CIS  ; CJS/MPLS 3-16-92 KILL LOCAL VARIABLES
         ;-I $P(^LR(LRDFN,0),U,2)=2 I '$D(ZZCARE) S ZRECORD=0,ZRECORD=$O(^SC("C",LRLLOC,ZRECORD)) I ZRECORD'="",$D(^LRTXFCS(5000024,1,618001,"B",ZRECORD)) D FCS  ; CJS/MPLS 3-16-92 LINE ADDED TO CHECK IF REQUESTING LOCATION IS CAREVUE SUPPORTED  ++RG
         S D1=1,X=0 F  S X=$O(^TMP("LR",$J,"TMP",X)) Q:X<1  S LRT=+^(X) I $D(LRM(X)) D REQ
         I $D(^LRO(69,LRODT,1,LRSN,0)) S ^(3)=$S($D(^(3)):+^(3),1:LRNOW) S:'$P(^(3),U,2) $P(^(3),U,2)=LRNOW
         I D1,'$D(A2) S:'$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,4) $P(^(3),U,4)=LRNOW,^LRO(68,LRAA,1,LRAD,1,"AC",LRNOW,LRAN)=""
         ; Class I CareVue routine TASKED if CareVue ward - pwc/10-2000
+        D
         . N I,LR7DLOC D IN5^VADPT S LR7DLOC=$G(^DIC(42,+$P($G(VAIP(5)),"^"),44))
         . Q:'LR7DLOC  D:$D(^LAB(62.487,"C",LR7DLOC))      ;good ward location
         . . S ZTRTN="^LA7DLOC",ZTDESC="LAB AUTOMATION CAREVUE SUPPORTED WARDS"
         . . S ZTIO="",ZTDTH=$H,ZTSAVE("L*")="" D ^%ZTLOAD
         . . K ZTSAVE,ZTSK,ZTRTN,ZTIO,ZTDTH,ZTDESC,ZTREQ,ZTQUEUED
         ;D ^VEICVLOC ;* PLS 6/3/99 -For HL7 interface
         I D1,'$D(A2),LRAD'=LRACD S:'$P(^LRO(68,LRAA,1,LRACD,1,LRAN,3),U,4) $P(^(3),U,4)=LRNOW,^LRO(68,LRAA,1,LRACD,1,"AC",LRNOW,LRAN)=""
         D XREF I $D(^LRO(68,LRAA,.2))'[0 X ^(.2)
         N CORRECT S:$G(LRCORECT) CORRECT=1 D NEW^LR7OB1(LRODT,LRSN,"RE",,.LRORTST)
         L -^LR(LRDFN,LRSS,LRIDT) ;unlock
+        Q
 XREF    ;from COM1^LRVER4 and VER^LRVER3A
         I +$G(LRDPF)=2,$$VER^LR7OU1<3 D EN^LROR(LRAA,LRAD,LRAN) ;OE/RR 2.5
         I LRDPF=62.3 S ^LRO(68,LRAA,1,LRAD,1,"AD",DT,LRAN)="" Q
         S LRPRAC=$$PRAC^LRX($P(^LR(LRDFN,LRSS,LRIDT,0),U,10)) ;get doc name
         S ^LRO(68,LRAA,1,LRAD,1,"AD",DT,LRAN)=""
         S ^LRO(69,9999999-LRIDT\1,1,"AL",$E(LRLLOC,1,15),$E(PNM,1,20),LRDFN)=""
         S ^LRO(69,9999999-LRIDT\1,1,"AP",LRPRAC,$E(PNM,1,20),LRDFN)=""
         S ^LRO(69,DT,1,"AN",$E(LRLLOC,1,15),LRDFN,LRIDT)=""
         S ^LRO(69,DT,1,"AR",$E(LRLLOC,1,15),$E(PNM,1,20),LRDFN)=""
         S ^LRO(69,"AN",$E(LRLLOC,1,20),LRDFN,LRIDT)=""
         D CHSET^LRPX(LRDFN,LRIDT)
         Q:'$P(LRPARAM,U,3)
 TSKM    F KK="LRDFN","LRAA","LRAOD","LRAD","LRAN","LRIDT","LRSS","LRLLOC","LRSN","LRODT" S ZTSAVE(KK)=""
         N %X S ZTRTN="DQ^LRTP",ZTIO="",ZTDTH=$H,ZTDESC="LAB INTERIM REPORTS" D ^%ZTLOAD
         K KK,ZTSK,ZTRTN,ZTDTH,ZTSAVE,ZTIO Q
 REQ     ;
         Q:$P($G(LRSB(X)),U)="comment"
         I $D(LRSB(X)),$P(LRSB(X),U)="canc" Q
         I $D(LRSB(X)),$P(LRSB(X),U)'["pending" Q
         I $L($P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0)),U,6)) Q
         S:'$G(LRALERT) LRALERT=$S($G(LROUTINE):LROUTINE,1:9)
         S D1=0 N A,LRPPURG
         I $D(LRSB(X)),LRSB(X)["pending",$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0))#2 D  G REQ1
         . S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0),U,4)="",$P(^(0),U,5,6)="^",$P(^(0),U,9)=+$G(LRM(X,"P"))
         I '$D(LRSB(X)),'$L($P($G(^LR(LRDFN,"CH",LRIDT,X)),U)) S $P(^(X),U)="pending"
         I '$D(LRSB(X)),$P($G(^LR(LRDFN,"CH",LRIDT,X)),U)'="pending" Q
         I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0))#2 S $P(^(0),U,4,5)="^",A=$P(^(0),U,2) I A>49 S $P(^(0),U,2)=$S(A=50:9,1:A-50)
         I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0))#2 D
         . S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",+LRT,+LRT)=""
         . S LRPPURG=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+$G(LRM(X,"P")),0)),U,2)
         . S:'LRPPURG LRPPURG=$S($G(LRALERT):+LRALERT,1:9)
         . S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0)=+LRT_U_LRPPURG,$P(^(0),U,9)=+$G(LRM(X,"P"))
         . S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),U,3)=+LRT,$P(^(0),U,4)=$P(^(0),U,4)+1 Q
 REQ1    ;
         Q:LRACD=LRAD  I $D(^LRO(68,LRAA,1,LRACD,1,LRAN,4,+LRT,0))#2,'$L($P(^(0),U,6)) S ^(0)=$P(^(0),U,1,2),$P(^(0),U,7)=1,$P(^(0),U,9)=+$G(LRM(X,"P"))
         K CNT,LRAMC Q
 FCS     ; SET UP FOR FOREIGN COMPUTER SYSTEM  ; CJS/MPLS 12-4-91 LINK TO CIS
         ;-S:'$D(ZRECORD) ZZCARE=1 S:$D(ZRECORD) ZTSAVE("LRLLOC")=""   ; CJS/MPLS 3-18-92 SET ZZCARE IF PATIENT IN ICU'S, SET ZTSAVE IF TEST REQUESTED FROM PAR/OR
         ;-F KK="LRDFN","LRIDT","DFN" S ZTSAVE(KK)=""
         ;-S ZTRTN="EN^LAFCCVX2",ZTIO="",ZTDTH=$H D ^%ZTLOAD
         ;-Q
+LRVER3A ;SLC/CJS/DALOI/FHS - DATA VERIFICATION ;5/27/03  14:49
+ ;;5.2;LAB SERVICE;**1,5,42,100,121,153,190,221,254,263,266,274,295**;Sep 27, 1994
+ ;Also contains LRORFLG to restrict multiple OERR alerts (VER+2)
+ ; Reference to ^DIC(42 supported by IA #10039
+ ; Reference to ^%ZTLOAD supported by DBIA #10063
+ ; Reference to IN5^VADPT supported by DBIA #10061
+ ; Reference to $$NOW^XLFDT supported by DBIA #10103
+ ;
+VER ;Call with L ^LR(LRDFN,LRSS,LRIDT) from LRGV2, LRGVG1, LRSTUF1, LRSTUF2, LRVR3
+ Q:'$O(LRSB(0))
+ N LRVCHK,LRORTST,LRORFLG,LRT
+ S LRORU3=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),(LRAOD,LRACD)=$P(^(0),U,3)
+ S LRACD=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,9)):^(9),1:LRACD)
+ S:'$D(^LRO(68,LRAA,1,LRACD,1,LRAN,0))#2 LRACD=LRAD
+ S LRAOD=$S($D(^LRO(68,LRAA,1,LRAOD,1,LRAN,0))#2:LRAOD,1:LRAD)
+ I '$G(LRFIX) S LRNOW=$$NOW^XLFDT,$P(^LR(LRDFN,LRSS,LRIDT,0),U,3,4)=LRNOW_U_$S($G(LRDUZ):LRDUZ,1:DUZ)
+ K A2 I '$D(PNM) S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX S:PNM="" PNM="NONAME"
+ N LRT S LRT=0 F  S LRT=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT)) Q:LRT<.5  S:$P(^(LRT,0),U,5)="" A2(LRT)=1 I $D(^TMP("LR",$J,"VTO",LRT)) S LRVCHK=+^(LRT) D
+ . I $S(LRVCHK<1:1,$D(LRSB(LRVCHK))#2:1,1:0) D
+ . . I $D(LRSB(LRVCHK)) Q:$P(LRSB(LRVCHK),U)=""
+ . . I LRVCHK<1,$L($P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0),U,6)) Q
+ . . D
+ . . . S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0),U,4)=$S($G(LRDUZ):LRDUZ,$G(DUZ):DUZ,1:"")
+ . . . S:'$P(^(0),U,5) $P(^(0),U,5)=LRNOW
+ . . . S $P(^(0),U,6)="",$P(^(0),U,8)=$G(LRCDEF)
+ . . S LRORTST(LRT)=""
+ . . I LRACD'=LRAD D
+ . . . Q:'$D(^LRO(68,LRAA,1,LRACD,1,LRAN,4,+LRT,0))  D
+ . . . . S $P(^LRO(68,LRAA,1,LRACD,1,LRAN,4,+LRT,0),U,4)=$S($G(LRDUZ):LRDUZ,$G(DUZ):DUZ,1:"")
+ . . . . S:'$P(^(0),U,5) $P(^(0),U,5)=LRNOW
+ . . . . S $P(^(0),U,6)="",$P(^(0),U,8)=$G(LRCDEF)
+ . . I $P($G(LRPARAM),U,14),$P($G(^LRO(68,+LRAA,0)),U,16) S ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_LRT)=""
+ . . K A2(LRT)
+ . . I +$G(LRDPF)=2,$$VER^LR7OU1<3 D
+ . . . N I,Y
+ . . . S Y=LRNOW,I=LRT D V^LROR ;OE/RR 2.5
+ ;-K ZZCARE,ZRECORD I $D(^LR(LRDFN,.3)),^LR(LRDFN,.3)'="" D FCS  ; CJS/MPLS 12-4-91 LINK TO CIS  ; CJS/MPLS 3-16-92 KILL LOCAL VARIABLES
+ ;-I $P(^LR(LRDFN,0),U,2)=2 I '$D(ZZCARE) S ZRECORD=0,ZRECORD=$O(^SC("C",LRLLOC,ZRECORD)) I ZRECORD'="",$D(^LRTXFCS(5000024,1,618001,"B",ZRECORD)) D FCS  ; CJS/MPLS 3-16-92 LINE ADDED TO CHECK IF REQUESTING LOCATION IS CAREVUE SUPPORTED  ++RG
+ S D1=1,X=0 F  S X=$O(^TMP("LR",$J,"TMP",X)) Q:X<1  S LRT=+^(X) I $D(LRM(X)) D REQ
+ S:$D(^LRO(69,LRODT,1,LRSN,0)) ^(3)=$S($D(^(3)):+^(3),1:LRNOW) S:'$P(^(3),U,2) $P(^(3),U,2)=LRNOW
+ I D1,'$D(A2) S:'$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,4) $P(^(3),U,4)=LRNOW,^LRO(68,LRAA,1,LRAD,1,"AC",LRNOW,LRAN)=""
+ ; Class I CareVue routine TASKED if CareVue ward - pwc/10-2000
+ D
+ . N I,LR7DLOC D IN5^VADPT S LR7DLOC=$G(^DIC(42,+$P($G(VAIP(5)),"^"),44))
+ . Q:'LR7DLOC  D:$D(^LAB(62.487,"C",LR7DLOC))      ;good ward location
+ . . S ZTRTN="^LA7DLOC",ZTDESC="LAB AUTOMATION CAREVUE SUPPORTED WARDS"
+ . . S ZTIO="",ZTDTH=$H,ZTSAVE("L*")="" D ^%ZTLOAD
+ . . K ZTSAVE,ZTSK,ZTRTN,ZTIO,ZTDTH,ZTDESC,ZTREQ,ZTQUEUED
+ ;D ^VEICVLOC ;* PLS 6/3/99 -For HL7 interface
+ I D1,'$D(A2),LRAD'=LRACD S:'$P(^LRO(68,LRAA,1,LRACD,1,LRAN,3),U,4) $P(^(3),U,4)=LRNOW,^LRO(68,LRAA,1,LRACD,1,"AC",LRNOW,LRAN)=""
+ D XREF I $D(^LRO(68,LRAA,.2))'[0 X ^(.2)
+ N CORRECT S:$G(LRCORECT) CORRECT=1 D NEW^LR7OB1(LRODT,LRSN,"RE",,.LRORTST)
+ L -^LR(LRDFN,LRSS,LRIDT) ;unlock
+ Q
+XREF ;from COM1^LRVER4 and VER^LRVER3A
+ I +$G(LRDPF)=2,$$VER^LR7OU1<3 D EN^LROR(LRAA,LRAD,LRAN) ;OE/RR 2.5
+ I LRDPF=62.3 S ^LRO(68,LRAA,1,LRAD,1,"AD",DT,LRAN)="" Q
+ S LRPRAC=$$PRAC^LRX($P(^LR(LRDFN,LRSS,LRIDT,0),U,10)) ;get doc name
+ S ^LRO(68,LRAA,1,LRAD,1,"AD",DT,LRAN)=""
+ S ^LRO(69,9999999-LRIDT\1,1,"AL",$E(LRLLOC,1,15),$E(PNM,1,20),LRDFN)=""
+ S ^LRO(69,9999999-LRIDT\1,1,"AP",LRPRAC,$E(PNM,1,20),LRDFN)=""
+ S ^LRO(69,DT,1,"AN",$E(LRLLOC,1,15),LRDFN,LRIDT)=""
+ S ^LRO(69,DT,1,"AR",$E(LRLLOC,1,15),$E(PNM,1,20),LRDFN)=""
+ S ^LRO(69,"AN",$E(LRLLOC,1,20),LRDFN,LRIDT)=""
+ D CHSET^LRPX(LRDFN,LRIDT)
+ Q:'$P(LRPARAM,U,3)
+TSKM F KK="LRDFN","LRAA","LRAOD","LRAD","LRAN","LRIDT","LRSS","LRLLOC","LRSN","LRODT" S ZTSAVE(KK)=""
+ N %X S ZTRTN="DQ^LRTP",ZTIO="",ZTDTH=$H,ZTDESC="LAB INTERIM REPORTS" D ^%ZTLOAD
+ K KK,ZTSK,ZTRTN,ZTDTH,ZTSAVE,ZTIO Q
+REQ ;
+ Q:$P($G(LRSB(X)),U)="comment"
+ I $D(LRSB(X)),$P(LRSB(X),U)="canc" Q
+ I $D(LRSB(X)),$P(LRSB(X),U)'["pending" Q
+ I $L($P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0)),U,6)) Q
+ S:'$G(LRALERT) LRALERT=$S($G(LROUTINE):LROUTINE,1:9)
+ S D1=0 N A,LRPPURG
+ I $D(LRSB(X)),LRSB(X)["pending",$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0))#2 D  G REQ1
+ . S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0),U,4)="",$P(^(0),U,5,6)="^",$P(^(0),U,9)=+$G(LRM(X,"P"))
+ I '$D(LRSB(X)),'$L($P($G(^LR(LRDFN,"CH",LRIDT,X)),U)) S $P(^(X),U)="pending"
+ I '$D(LRSB(X)),$P($G(^LR(LRDFN,"CH",LRIDT,X)),U)'="pending" Q
+ I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0))#2 S $P(^(0),U,4,5)="^",A=$P(^(0),U,2) I A>49 S $P(^(0),U,2)=$S(A=50:9,1:A-50)
+ I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0))#2 D
+ . S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",+LRT,+LRT)=""
+ . S LRPPURG=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+$G(LRM(X,"P")),0)),U,2)
+ . S:'LRPPURG LRPPURG=$S($G(LRALERT):+LRALERT,1:9)
+ . S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0)=+LRT_U_LRPPURG,$P(^(0),U,9)=+$G(LRM(X,"P"))
+ . S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),U,3)=+LRT,$P(^(0),U,4)=$P(^(0),U,4)+1 Q
+REQ1 ;
+ Q:LRACD=LRAD  I $D(^LRO(68,LRAA,1,LRACD,1,LRAN,4,+LRT,0))#2,'$L($P(^(0),U,6)) S ^(0)=$P(^(0),U,1,2),$P(^(0),U,7)=1,$P(^(0),U,9)=+$G(LRM(X,"P"))
+ K CNT,LRAMC Q
+FCS ; SET UP FOR FOREIGN COMPUTER SYSTEM  ; CJS/MPLS 12-4-91 LINK TO CIS
+ ;-S:'$D(ZRECORD) ZZCARE=1 S:$D(ZRECORD) ZTSAVE("LRLLOC")=""   ; CJS/MPLS 3-18-92 SET ZZCARE IF PATIENT IN ICU'S, SET ZTSAVE IF TEST REQUESTED FROM PAR/OR
+ ;-F KK="LRDFN","LRIDT","DFN" S ZTSAVE(KK)=""
+ ;-S ZTRTN="EN^LAFCCVX2",ZTIO="",ZTDTH=$H D ^%ZTLOAD
+ ;-Q

WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRWLST1.m

-              r613
+              r623
+LRWLST1 ;DALOI/CJS/RWF/FHS - ACCESSION SETUP ; July 19, 2006
+        ;;5.2;LAB SERVICE;**48,65,121,153,261,286,331,379**;Sep 27, 1994;Build 2
+        ;
+        ; Reference to ^DIC(42 supported by IA #10039
+        ; Reference to ^SC( supported by IA #10040
+        ;
+        S LRWLC=0
+        F  S LRWLC=$O(LRTSTS(LRWLC)) Q:LRWLC<1  S LRAD=DT D SPLIT
+        ;
+        ; If LEDI and comments came with order then copy to order in #69
+        I $G(LRORDRR)="R",$G(LR696),$D(^LRO(69.6,LR696,99)) D
+        . N LRDIE
+        . D WP^DIE(69.01,LRSN_","_LRODT_",",16,"A","^LRO(69.6,LR696,99)","LRDIE(16)")
+        ;
+        K DIC,DLAYGO,DR,DA,DIE,LRIXX
+        Q:$G(LRORDR)="P"
+        K LRNM,LRTSTS
+        K ^TMP("LR",$J,"TMP")
+        Q
+        ;
+SPLIT   ;
+        N LRAA,LRX
+        ; Setup regular accessions (LRUNQ=0)
+        S LRUNQ=0,LREND=0
+        I $D(LRTSTS(LRWLC,0)) D
+        . D GTWLN
+        . I LREND Q
+        . S LRAA=0
+        . F  S LRAA=$O(LRTSTS(LRWLC,0,LRAA)) Q:LRAA<1  D
+        . . S LRSS=LRTSTS(LRWLC,0,LRAA)
+        . . D STWLN,ST2,^LRWLST11,EN^LA7ADL(LRUID)
+        . D SICA^LRWLST11
+        ;
+        ; Setup accessions requiring 'unique' accession numbers (LRUNQ=1)
+        S LRUNQ=1,LRAA=0
+        F  S LRAA=$O(LRTSTS(LRWLC,1,LRAA)) Q:LRAA<1  D
+        . S LRSS=LRTSTS(LRWLC,1,LRAA)
+        . F  D GTWLN Q:LREND  D   Q:$O(LRTSTS(LRWLC,1,LRAA,0))<1
+        . . D STWLN,ST2,^LRWLST11,EN^LA7ADL(LRUID),SICA^LRWLST11
+        Q
+        ;
+        ;
+STWLN   ; Set accession number
+        ;
+        D GETLOCK(LRAA,LRAD)
+        D CHECK68(LRAA,LRAD)
+        ;
+        S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
+        ;
+        ; Handle 'in common' area that was not setup in GTWLN call.
+        I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN)) D SETAN(LRAA,LRAD,LRAN)
+        ;
+        S LREND=0,LRLBLBP=1-$P(LRSS,U,2),LRSS=$P(LRSS,U)
+        S LRACC=$P(^LRO(68,LRAA,0),U,11)_" "_$S(LRAD["0000":$E(LRAD,2,3),1:$E(LRAD,4,7))_" "_LRAN
+        ;
+        S LRPRAC=""
+        I $D(^LRO(69,LRODT,1,LRSN,0)) S LRPRAC=$P(^(0),U,6) S:$D(LRNT) ^(3)=LRNT
+        ;
+        ; Location type
+        S LRCAPLOC=$P($G(^SC(+LROLLOC,0)),U,3)
+        I LRCAPLOC="" S LRCAPLOC="Z"
+        ;
+        ; File information in file #68 for this accession
+        N FDA,LR6802,LRDIE
+        S LR6802=LRAN_","_LRAD_","_LRAA_","
+        S FDA(1,68.02,LR6802,.01)=LRDFN
+        S FDA(1,68.02,LR6802,1)=LRDPF
+        S FDA(1,68.02,LR6802,2)=LRAD
+        S FDA(1,68.02,LR6802,3)=LRODT
+        S FDA(1,68.02,LR6802,4)=LRSN
+        S FDA(1,68.02,LR6802,6)=LRLLOC
+        S X=$G(^LRO(69,LRODT,1,LRSN,.1)) I X'="" S FDA(1,68.02,LR6802,14)=X
+        ;
+        ; No ordering provider/location on controls
+        I LRDPF'=62.3 D
+        . S FDA(1,68.02,LR6802,6.5)=LRPRAC
+        . S FDA(1,68.02,LR6802,94)=LROLLOC
+        ;
+        ; Only store treating specialty on file #2 patients
+        ; If no treating specialty then use specialty from file #44 location
+        I LRDPF=2 D
+        . S LRTREA=$P($G(^DPT(DFN,.103)),U)
+        . I 'LRTREA S LRTREA=$P($G(^SC(+LROLLOC,0)),U,20)
+        . I LRTREA S FDA(1,68.02,LR6802,6.6)=LRTREA
+        ;
+        S FDA(1,68.02,LR6802,6.7)=DUZ
+        S FDA(1,68.02,LR6802,15)=LRACC
+        S FDA(1,68.02,LR6802,26)=DUZ(2)
+        S FDA(1,68.02,LR6802,92)=LRCAPLOC
+        ;
+        D FILE^DIE("","FDA(1)","LRDIE(1)")
+        I $D(LRDIE(1)) D MAILALRT
+        ;
+        ; If specimen defined then set nodes, force to ien=1 since many lab
+        ; routines expect the specimen to be record number 1.
+        I $G(LRSPEC) D
+        . N FDAIEN
+        . S FDAIEN(1)=1
+        . S FDA(2,68.05,"+1,"_LR6802,.01)=LRSPEC
+        . S FDA(2,68.05,"+1,"_LR6802,1)=$P(LRSAMP,";",1)
+        . ;
+        . ; Modification to prevent lock failures - loop 10 times to give system a chance to get lock
+        . N LRLOCKOK,LRLOOPCT
+        . S LRLOCKOK=0
+        . F LRLOOPCT=1:1:10 Q:LRLOCKOK  D  I 'LRLOCKOK H 5
+        . . K LRDIE(2)
+        . . D UPDATE^DIE("","FDA(2)","FDAIEN","LRDIE(2)")
+        . . S:$D(LRDIE(2))=0 LRLOCKOK=1
+        . K LRLOCKOK,LRLOOPCT
+        . ;
+        . ;D UPDATE^DIE("","FDA(2)","FDAIEN","LRDIE(2)")
+        . I $D(LRDIE(2)) D MAILALRT
+        ;
+        ; If no specimen defined then use specimen values from file #69.
+        I $G(LRSPEC)="",$D(^LRO(69,LRODT,1,LRSN,4,0)) D
+        . N FDA,FDAIEN,LRI,LRX
+        . S LRI=0
+        . F  S LRI=$O(^LRO(69,LRODT,1,LRSN,4,LRI)) Q:'LRI  D
+        . . S FDAIEN(1)=LRI,LRX=$G(^LRO(69,LRODT,1,LRSN,4,LRI,0))
+        . . S FDA(LRI,68.05,"+1,"_LR6802,.01)=$P(LRX,"^")
+        . . D UPDATE^DIE("","FDA(LRI)","FDAIEN","LRDIE(LRI)")
+        . . I $D(LRDIE(LRI)) D MAILALRT
+        ;
+        ; Create UID.
+        S LRUID=$$LRUID^LRX(LRAA,LRAD,LRAN)
+        ;
+        I '$D(LRPHSET),('$G(LRQUIET)) W !!,"ACCESSION:  ",LRACC,"  <",LRUID,">"
+        ;
+        D UPD696
+        ;
+        L -^LRO(68,LRAA,1,LRAD,1,0)
+        Q
+        ;
+        ;
+UPD696  ; Update file #69.6 if LEDI referral patient and no existing entry
+        K LR696IEN
+        I $G(LRORDRR)="R" D
+        . S LR696IEN=0
+        . I $G(LRRSITE("SMID"))'="",$G(LRSD("RUID"))'="" S LR696IEN=+$O(^LRO(69.6,"AD",LRRSITE("SMID"),LRSD("RUID"),0))
+        . I LR696IEN Q
+        . I '$G(LRRSTAT(0)) S LRRSTAT(0)=$$FIND1^DIC(64.061,"","OMX","Specimen in process","","I $P(^LAB(64.061,Y,0),U,7)=""U""")
+        . D PSET^LRPEND(SSN(2),+LRRSITE("RSITE"),LRSD("RUID"),+LRSD("RPSITE"),LRSPEC,LRSAMP,LRRSTAT(0),LRODT,$P(LRCDT,U),LRRSITE("SDT"),LRNT,.LROT)
+        Q
+        ;
+        ;
+ST2     ; Find next available node in LR global
+        ;
+        N FDA,FDAIEN,LRDIE,LRX,LRXIDT
+        ;
+        ; Autopsy ("AU") is not a mulitple - do not attempt to set in ^LR global
+        I LRSS="AU" S LRIDT=0 Q
+        ;
+        S LRIDT=0
+        F  D  Q:LRIDT
+        . S LRXIDT=9999999-LRCDT
+        . L +^LR(LRDFN,LRSS,LRXIDT,0):5
+        . I '$T S LRCDT=$$FMADD^XLFDT(LRCDT,0,0,0,1) Q
+        . I '$D(^LR(LRDFN,LRSS,LRXIDT,0)) S LRIDT=LRXIDT Q
+        . L -^LR(LRDFN,LRSS,LRXIDT,0)
+        . S LRCDT=$$FMADD^XLFDT(LRCDT,0,0,0,1)
+        ;
+        ; Create entry in appropriate subscript in LAB DATA file (#63).
+        S LRX=$S(LRSS="CH":63.04,LRSS="MI":63.05,LRSS="BB":63.01,LRSS="SP":63.08,LRSS="CY":63.09,LRSS="EM":63.02,1:0)
+        S FDAIEN(1)=LRIDT
+        S FDA(63,LRX,"+1,"_LRDFN_",",.01)=LRCDT
+        S FDA(63,LRX,"+1,"_LRDFN_",",.06)=LRACC
+        I LRSS'="CH" S FDA(63,LRX,"+1,"_LRDFN_",",.1)=LRNT
+        I LRSS="CH" S FDA(63,LRX,"+1,"_LRDFN_",",.12)=3
+        I LRSS="MI" S FDA(63,LRX,"+1,"_LRDFN_",",38)=3
+        I LRX D UPDATE^DIE("","FDA(63)","FDAIEN","LRDIE(63)")
+        I $D(LRDIE(63)) D MAILALRT
+        ;
+        ; Uncomment following code when new field .9 in"MI" subscript is released
+        ;I LRSS="MI" D
+        ;. N LRN,ERR,IENS
+        ;. S IENS=LRIDT_","_LRDFN_",",LRN=0
+        ;. F  S LRN=$O(^LRO(69,LRODT,1,LRSN,2,LRN)) Q:LRN<1  D
+        ;. . I '$D(^LRO(69,LRODT,1,LRSN,2,LRN,1,0)) Q
+        ;. . D WP^DIE(63.05,IENS,.9,"A","^LRO(69,"_LRODT_",1,"_LRSN_",2,"_LRN_",1)","ERR")
+        ;
+        L -^LR(LRDFN,LRSS,LRIDT,0)
+        ;
+        Q
+        ;
+        ;
+GTWLN   ;
+        N X
+        ;
+        ; Execute accession transform for this area.
+        S LRAN=0
+        S X=$G(^LRO(68,LRWLC,.1)) X:X'="" X
+        ;
+        D GETLOCK(LRWLC,LRAD)
+        D CHECK68(LRWLC,LRAD)
+        ;
+        S:'LRAN LRAN=1+$P($G(^LRO(68,LRWLC,1,LRAD,1,0)),U,3)
+        ;
+        I "CYEMSP"'[LRSS F  Q:'$D(^LRO(68,LRWLC,1,LRAD,1,LRAN))  S LRAN=LRAN+1
+        ;
+        ; check for AP Accessions
+        I "CYEMSP"[LRSS F  Q:'$D(^LRO(68,LRWLC,1,LRAD,1,LRAN))&'$D(^LR("A"_LRSS_"A",$E(LRAD,1,3),LRAN))  S LRAN=LRAN+1
+        ;
+        I '$D(LRPHSET),$D(LRNCWL)!$P(^LAB(69.9,1,0),U,8) D ASK Q:LREND
+        ;
+        D SETAN(LRWLC,LRAD,LRAN)
+        ;
+        L -^LRO(68,LRWLC,1,LRAD,1,0)
+        Q
+        ;
+        ;
+ASK     ;
+        ; Don't ask if tasked or a "silent" call
+        I $D(ZTQUEUED)!($G(LRQUIET)) Q
+        ;
+        N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LROK,LRANX,X,Y
+        S LROK=0
+        F  D  Q:LREND!(LROK)
+        . K DIR
+        . S DIR(0)="NO^1:"_$S($P(LRLABKY,U,2):999999,1:LRAN)_":0"
+        . S DIR("A")="Force to",DIR("B")=LRAN
+        . D ^DIR
+        . I $D(DIRUT) S LREND=1 Q
+        . S LRANX=Y
+        . I LRANX<+$P($G(^LRO(68,LRWLC,1,LRAD,1,0)),U,3) D
+        . . W !,"This accession number may be already assigned either in this "
+        . . W !,"area or a common accession area."
+        . I $D(^LRO(68,LRWLC,1,LRAD,1,LRANX,0)) D  Q:'LROK
+        . . N LRDFNX S LRDFNX=LRDFN
+        . . N DFN,LRDFN,LRDPF,PNM,SSN
+        . . S LRDFN=+^LRO(68,LRWLC,1,LRAD,1,LRANX,0),LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^LR(LRDFN,0),U,3)
+        . . D PT^LRX
+        . . W !,"THIS NUMBER BELONGS TO ",!,PNM,"     SSN: ",SSN
+        . . D INF^LRX
+        . . I LRDFN=LRDFNX S LROK=1
+        . K DIR
+        . S DIR(0)="YO",DIR("A")="Are you sure",DIR("B")="NO"
+        . D ^DIR
+        . I $D(DIRUT) S LREND=1 Q
+        . I Y=1 S LRAN=LRANX,LROK=1
+        ;
+        ; Unlock if aborting.
+        I LREND L -^LRO(68,LRWLC,1,LRAD,1,0)
+        ;
+        Q
+        ;
+        ;
+CHECK68(LRAA,LRAD)      ; Check for/set header node of ^LRO(68) 68.01 subfile.
+        ;
+        ; Call with LRAA = ien of entry in file #68
+        ;           LRAD = accession date in fileman format
+        ;
+        ; Set accession date in file #68 for this acession.
+        ; Check for existence of accession number multiple but not accession date multiple,
+        ; FileMan DBS call fails when accession number multiple exists but accession date multiple does not.
+        ; If this condition found then set missing node directly and quit.
+        ;
+        I '$D(^LRO(68,LRAA,1,LRAD,0)) D
+        . N FDA,FDAIEN,LRDIE,X
+        . S X=$Q(^LRO(68,LRAA,1,LRAD,0))
+        . I X'="",$QS(X,4)=LRAD S $P(^LRO(68,LRAA,1,LRAD,0),"^")=LRAD Q
+        . S (FDAIEN(1),FDA(1,68.01,"+1,"_LRAA_",",.01))=LRAD
+        . D UPDATE^DIE("","FDA(1)","FDAIEN","LRDIE(1)")
+        . I $D(LRDIE(1)) D MAILALRT
+        ;
+        Q
+        ;
+        ;
+GETLOCK(LRAA,LRAD)      ; Obtain lock on zeroth node of this accession date
+        ; Call with LRAA = ien of entry in file #68
+        ;           LRAD = accession date in fileman format
+        ;
+        F  L +^LRO(68,LRAA,1,LRAD,1,0):10 Q:$T  D
+        . I $D(ZTQUEUED)!($G(LRQUIET)) Q
+        . W !!?5,"Accession area ",$P(^LRO(68,LRAA,0),"^")," is locked by another user.",!,$C(7)
+        Q
+        ;
+        ;
+SETAN(LRAA,LRAD,LRAN)   ; Create stub entry in file #68 for this acession.
+        ;
+        ; Call with LRAA = ien of entry in file #68
+        ;           LRAD = accession date in fileman format
+        ;           LRAN = accession number
+        ;
+        N FDA,FDAIEN,LR6802,LRDIE
+        ;
+        S LR6802=LRAD_","_LRAA_","
+        S FDAIEN(1)=LRAN
+        S FDA(2,68.02,"+1,"_LR6802,.01)=LRDFN
+        ;
+        ; Modification to prevent lock failures - loop 10 times to give system a chance to get lock
+        N LRLOCKOK,LRLOOPCT
+        S LRLOCKOK=0
+        F LRLOOPCT=1:1:10 Q:LRLOCKOK  D  I 'LRLOCKOK H 5
+        . K LRDIE(2)
+        . D UPDATE^DIE("","FDA(2)","FDAIEN","LRDIE(2)")
+        . S:$D(LRDIE(2))=0 LRLOCKOK=1
+        K LRLOCKOK,LRLOOPCT
+        ;
+        ;D UPDATE^DIE("","FDA(2)","FDAIEN","LRDIE(2)")
+        I $D(LRDIE(2)) D MAILALRT
+        Q
+        ;
+        ;
+MAILALRT        ; Send mail message alert when FileMan DBS errors returned
+        ;
+        N J,LR68,LRCNT,LRMTXT,X,XMINSTR,XMSUB,XMTO
+        ;
+        I $D(^LRO(68,LRAA,1,LRAD,1,LRAN)) M LR68=^LRO(68,LRAA,1,LRAD,1,LRAN)
+        ;
+        S LRMTXT(1)="The following debugging information is provided to assist"
+        S LRMTXT(2)="support staff in resolving error during accessioning."
+        S LRMTXT(3)=" "
+        S LRCNT=3
+        ;
+        F J="FDA","FDAIEN","LR68","LRAA","LRAD","LRAN","LRDFN","LRDIE","LRSS","LRTSTS","LRUNQ","LRWLC","XQY","XQY0" D
+        . S X=$G(@J)
+        . I X'="" S LRCNT=LRCNT+1,LRMTXT(LRCNT)=J_"="_X
+        . F  S J=$Q(@J) Q:J=""  S LRCNT=LRCNT+1,LRMTXT(LRCNT)=J_"="_@J
+        ;
+        S XMSUB="FileMan DBS call failed during accessioning in routine LRWLST1"
+        S XMTO("G.LMI")=""
+        S XMINSTR("FROM")=.5
+        S XMINSTR("ADDR FLAGS")="R"
+        D SENDMSG^XMXAPI(DUZ,XMSUB,"LRMTXT",.XMTO,.XMINSTR)
+        Q
+LRWLST1 ;DALOI/CJS/RWF/FHS - ACCESSION SETUP ; July 19, 2006
+ ;;5.2;LAB SERVICE;**48,65,121,153,261,286,331**;Sep 27, 1994;Build 7
+ ;
+ ; Reference to ^DIC(42 supported by IA #10039
+ ; Reference to ^SC( supported by IA #10040
+ ;
+ S LRWLC=0
+ F  S LRWLC=$O(LRTSTS(LRWLC)) Q:LRWLC<1  S LRAD=DT D SPLIT
+ ;
+ ; If LEDI and comments came with order then copy to order in #69
+ I $G(LRORDRR)="R",$G(LR696),$D(^LRO(69.6,LR696,99)) D
+ . N LRDIE
+ . D WP^DIE(69.01,LRSN_","_LRODT_",",16,"A","^LRO(69.6,LR696,99)","LRDIE(16)")
+ ;
+ K DIC,DLAYGO,DR,DA,DIE,LRIXX
+ Q:$G(LRORDR)="P"
+ K LRNM,LRTSTS
+ K ^TMP("LR",$J,"TMP")
+ Q
+ ;
+SPLIT ;
+ N LRAA,LRX
+ ; Setup regular accessions (LRUNQ=0)
+ S LRUNQ=0,LREND=0
+ I $D(LRTSTS(LRWLC,0)) D
+ . D GTWLN
+ . I LREND Q
+ . S LRAA=0
+ . F  S LRAA=$O(LRTSTS(LRWLC,0,LRAA)) Q:LRAA<1  D
+ . . S LRSS=LRTSTS(LRWLC,0,LRAA)
+ . . D STWLN,ST2,^LRWLST11,EN^LA7ADL(LRUID)
+ . D SICA^LRWLST11
+ ;
+ ; Setup accessions requiring 'unique' accession numbers (LRUNQ=1)
+ S LRUNQ=1,LRAA=0
+ F  S LRAA=$O(LRTSTS(LRWLC,1,LRAA)) Q:LRAA<1  D
+ . S LRSS=LRTSTS(LRWLC,1,LRAA)
+ . F  D GTWLN Q:LREND  D   Q:$O(LRTSTS(LRWLC,1,LRAA,0))<1
+ . . D STWLN,ST2,^LRWLST11,EN^LA7ADL(LRUID),SICA^LRWLST11
+ Q
+ ;
+ ;
+STWLN ; Set accession number
+ ;
+ D GETLOCK(LRAA,LRAD)
+ D CHECK68(LRAA,LRAD)
+ ;
+ S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
+ ;
+ ; Handle 'in common' area that was not setup in GTWLN call.
+ I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN)) D SETAN(LRAA,LRAD,LRAN)
+ ;
+ S LREND=0,LRLBLBP=1-$P(LRSS,U,2),LRSS=$P(LRSS,U)
+ S LRACC=$P(^LRO(68,LRAA,0),U,11)_" "_$S(LRAD["0000":$E(LRAD,2,3),1:$E(LRAD,4,7))_" "_LRAN
+ ;
+ S LRPRAC=""
+ I $D(^LRO(69,LRODT,1,LRSN,0)) S LRPRAC=$P(^(0),U,6) S:$D(LRNT) ^(3)=LRNT
+ ;
+ ; Location type
+ S LRCAPLOC=$P($G(^SC(+LROLLOC,0)),U,3)
+ I LRCAPLOC="" S LRCAPLOC="Z"
+ ;
+ ; File information in file #68 for this accession
+ N FDA,LR6802,LRDIE
+ S LR6802=LRAN_","_LRAD_","_LRAA_","
+ S FDA(1,68.02,LR6802,.01)=LRDFN
+ S FDA(1,68.02,LR6802,1)=LRDPF
+ S FDA(1,68.02,LR6802,2)=LRAD
+ S FDA(1,68.02,LR6802,3)=LRODT
+ S FDA(1,68.02,LR6802,4)=LRSN
+ S FDA(1,68.02,LR6802,6)=LRLLOC
+ S X=$G(^LRO(69,LRODT,1,LRSN,.1)) I X'="" S FDA(1,68.02,LR6802,14)=X
+ ;
+ ; No ordering provider/location on controls
+ I LRDPF'=62.3 D
+ . S FDA(1,68.02,LR6802,6.5)=LRPRAC
+ . S FDA(1,68.02,LR6802,94)=LROLLOC
+ ;
+ ; Only store treating specialty on file #2 patients
+ ; If no treating specialty then use specialty from file #44 location
+ I LRDPF=2 D
+ . S LRTREA=$P($G(^DPT(DFN,.103)),U)
+ . I 'LRTREA S LRTREA=$P($G(^SC(+LROLLOC,0)),U,20)
+ . I LRTREA S FDA(1,68.02,LR6802,6.6)=LRTREA
+ ;
+ S FDA(1,68.02,LR6802,6.7)=DUZ
+ S FDA(1,68.02,LR6802,15)=LRACC
+ S FDA(1,68.02,LR6802,26)=DUZ(2)
+ S FDA(1,68.02,LR6802,92)=LRCAPLOC
+ ;
+ D FILE^DIE("","FDA(1)","LRDIE(1)")
+ I $D(LRDIE(1)) D MAILALRT
+ ;
+ ; If specimen defined then set nodes, force to ien=1 since many lab
+ ; routines expect the specimen to be record number 1.
+ I $G(LRSPEC) D
+ . N FDAIEN
+ . S FDAIEN(1)=1
+ . S FDA(2,68.05,"+1,"_LR6802,.01)=LRSPEC
+ . S FDA(2,68.05,"+1,"_LR6802,1)=$P(LRSAMP,";",1)
+ . D UPDATE^DIE("","FDA(2)","FDAIEN","LRDIE(2)")
+ . I $D(LRDIE(2)) D MAILALRT
+ ;
+ ; If no specimen defined then use specimen values from file #69.
+ I $G(LRSPEC)="",$D(^LRO(69,LRODT,1,LRSN,4,0)) D
+ . N FDA,FDAIEN,LRI,LRX
+ . S LRI=0
+ . F  S LRI=$O(^LRO(69,LRODT,1,LRSN,4,LRI)) Q:'LRI  D
+ . . S FDAIEN(1)=LRI,LRX=$G(^LRO(69,LRODT,1,LRSN,4,LRI,0))
+ . . S FDA(LRI,68.05,"+1,"_LR6802,.01)=$P(LRX,"^")
+ . . D UPDATE^DIE("","FDA(LRI)","FDAIEN","LRDIE(LRI)")
+ . . I $D(LRDIE(LRI)) D MAILALRT
+ ;
+ ; Create UID.
+ S LRUID=$$LRUID^LRX(LRAA,LRAD,LRAN)
+ ;
+ I '$D(LRPHSET),('$G(LRQUIET)) W !!,"ACCESSION:  ",LRACC,"  <",LRUID,">"
+ ;
+ D UPD696
+ ;
+ L -^LRO(68,LRAA,1,LRAD,1,0)
+ Q
+ ;
+ ;
+UPD696 ; Update file #69.6 if LEDI referral patient and no existing entry
+ K LR696IEN
+ I $G(LRORDRR)="R" D
+ . S LR696IEN=0
+ . I $G(LRRSITE("SMID"))'="",$G(LRSD("RUID"))'="" S LR696IEN=+$O(^LRO(69.6,"AD",LRRSITE("SMID"),LRSD("RUID"),0))
+ . I LR696IEN Q
+ . I '$G(LRRSTAT(0)) S LRRSTAT(0)=$$FIND1^DIC(64.061,"","OMX","Specimen in process","","I $P(^LAB(64.061,Y,0),U,7)=""U""")
+ . D PSET^LRPEND(SSN(2),+LRRSITE("RSITE"),LRSD("RUID"),+LRSD("RPSITE"),LRSPEC,LRSAMP,LRRSTAT(0),LRODT,$P(LRCDT,U),LRRSITE("SDT"),LRNT,.LROT)
+ Q
+ ;
+ ;
+ST2 ; Find next available node in LR global
+ ;
+ N FDA,FDAIEN,LRDIE,LRX,LRXIDT
+ ;
+ ; Autopsy ("AU") is not a mulitple - do not attempt to set in ^LR global
+ I LRSS="AU" S LRIDT=0 Q
+ ;
+ S LRIDT=0
+ F  D  Q:LRIDT
+ . S LRXIDT=9999999-LRCDT
+ . L +^LR(LRDFN,LRSS,LRXIDT,0):5
+ . I '$T S LRCDT=$$FMADD^XLFDT(LRCDT,0,0,0,1) Q
+ . I '$D(^LR(LRDFN,LRSS,LRXIDT,0)) S LRIDT=LRXIDT Q
+ . L -^LR(LRDFN,LRSS,LRXIDT,0)
+ . S LRCDT=$$FMADD^XLFDT(LRCDT,0,0,0,1)
+ ;
+ ; Create entry in appropriate subscript in LAB DATA file (#63).
+ S LRX=$S(LRSS="CH":63.04,LRSS="MI":63.05,LRSS="BB":63.01,LRSS="SP":63.08,LRSS="CY":63.09,LRSS="EM":63.02,1:0)
+ S FDAIEN(1)=LRIDT
+ S FDA(63,LRX,"+1,"_LRDFN_",",.01)=LRCDT
+ S FDA(63,LRX,"+1,"_LRDFN_",",.06)=LRACC
+ I LRSS'="CH" S FDA(63,LRX,"+1,"_LRDFN_",",.1)=LRNT
+ I LRSS="CH" S FDA(63,LRX,"+1,"_LRDFN_",",.12)=3
+ I LRSS="MI" S FDA(63,LRX,"+1,"_LRDFN_",",38)=3
+ I LRX D UPDATE^DIE("","FDA(63)","FDAIEN","LRDIE(63)")
+ I $D(LRDIE(63)) D MAILALRT
+ ;
+ ; Uncomment following code when new field .9 in"MI" subscript is released
+ ;I LRSS="MI" D
+ ;. N LRN,ERR,IENS
+ ;. S IENS=LRIDT_","_LRDFN_",",LRN=0
+ ;. F  S LRN=$O(^LRO(69,LRODT,1,LRSN,2,LRN)) Q:LRN<1  D
+ ;. . I '$D(^LRO(69,LRODT,1,LRSN,2,LRN,1,0)) Q
+ ;. . D WP^DIE(63.05,IENS,.9,"A","^LRO(69,"_LRODT_",1,"_LRSN_",2,"_LRN_",1)","ERR")
+ ;
+ L -^LR(LRDFN,LRSS,LRIDT,0)
+ ;
+ Q
+ ;
+ ;
+GTWLN ;
+ N X
+ ;
+ ; Execute accession transform for this area.
+ S LRAN=0
+ S X=$G(^LRO(68,LRWLC,.1)) X:X'="" X
+ ;
+ D GETLOCK(LRWLC,LRAD)
+ D CHECK68(LRWLC,LRAD)
+ ;
+ S:'LRAN LRAN=1+$P($G(^LRO(68,LRWLC,1,LRAD,1,0)),U,3)
+ ;
+ I "CYEMSP"'[LRSS F  Q:'$D(^LRO(68,LRWLC,1,LRAD,1,LRAN))  S LRAN=LRAN+1
+ ;
+ ; check for AP Accessions
+ I "CYEMSP"[LRSS F  Q:'$D(^LRO(68,LRWLC,1,LRAD,1,LRAN))&'$D(^LR("A"_LRSS_"A",$E(LRAD,1,3),LRAN))  S LRAN=LRAN+1
+ ;
+ I '$D(LRPHSET),$D(LRNCWL)!$P(^LAB(69.9,1,0),U,8) D ASK Q:LREND
+ ;
+ D SETAN(LRWLC,LRAD,LRAN)
+ ;
+ L -^LRO(68,LRWLC,1,LRAD,1,0)
+ Q
+ ;
+ ;
+ASK ;
+ ; Don't ask if tasked or a "silent" call
+ I $D(ZTQUEUED)!($G(LRQUIET)) Q
+ ;
+ N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LROK,LRANX,X,Y
+ S LROK=0
+ F  D  Q:LREND!(LROK)
+ . K DIR
+ . S DIR(0)="NO^1:"_$S($P(LRLABKY,U,2):999999,1:LRAN)_":0"
+ . S DIR("A")="Force to",DIR("B")=LRAN
+ . D ^DIR
+ . I $D(DIRUT) S LREND=1 Q
+ . S LRANX=Y
+ . I LRANX<+$P($G(^LRO(68,LRWLC,1,LRAD,1,0)),U,3) D
+ . . W !,"This accession number may be already assigned either in this "
+ . . W !,"area or a common accession area."
+ . I $D(^LRO(68,LRWLC,1,LRAD,1,LRANX,0)) D  Q:'LROK
+ . . N LRDFNX S LRDFNX=LRDFN
+ . . N DFN,LRDFN,LRDPF,PNM,SSN
+ . . S LRDFN=+^LRO(68,LRWLC,1,LRAD,1,LRANX,0),LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^LR(LRDFN,0),U,3)
+ . . D PT^LRX
+ . . W !,"THIS NUMBER BELONGS TO ",!,PNM,"     SSN: ",SSN
+ . . D INF^LRX
+ . . I LRDFN=LRDFNX S LROK=1
+ . K DIR
+ . S DIR(0)="YO",DIR("A")="Are you sure",DIR("B")="NO"
+ . D ^DIR
+ . I $D(DIRUT) S LREND=1 Q
+ . I Y=1 S LRAN=LRANX,LROK=1
+ ;
+ ; Unlock if aborting.
+ I LREND L -^LRO(68,LRWLC,1,LRAD,1,0)
+ ;
+ Q
+ ;
+ ;
+CHECK68(LRAA,LRAD) ; Check for/set header node of ^LRO(68) 68.01 subfile.
+ ;
+ ; Call with LRAA = ien of entry in file #68
+ ;           LRAD = accession date in fileman format
+ ;
+ ; Set accession date in file #68 for this acession.
+ ; Check for existence of accession number multiple but not accession date multiple,
+ ; FileMan DBS call fails when accession number multiple exists but accession date multiple does not.
+ ; If this condition found then set missing node directly and quit.
+ ;
+ I '$D(^LRO(68,LRAA,1,LRAD,0)) D
+ . N FDA,FDAIEN,LRDIE,X
+ . S X=$Q(^LRO(68,LRAA,1,LRAD,0))
+ . I X'="",$QS(X,4)=LRAD S $P(^LRO(68,LRAA,1,LRAD,0),"^")=LRAD Q
+ . S (FDAIEN(1),FDA(1,68.01,"+1,"_LRAA_",",.01))=LRAD
+ . D UPDATE^DIE("","FDA(1)","FDAIEN","LRDIE(1)")
+ . I $D(LRDIE(1)) D MAILALRT
+ ;
+ Q
+ ;
+ ;
+GETLOCK(LRAA,LRAD) ; Obtain lock on zeroth node of this accession date
+ ; Call with LRAA = ien of entry in file #68
+ ;           LRAD = accession date in fileman format
+ ;
+ F  L +^LRO(68,LRAA,1,LRAD,1,0):10 Q:$T  D
+ . I $D(ZTQUEUED)!($G(LRQUIET)) Q
+ . W !!?5,"Accession area ",$P(^LRO(68,LRAA,0),"^")," is locked by another user.",!,$C(7)
+ Q
+ ;
+ ;
+SETAN(LRAA,LRAD,LRAN) ; Create stub entry in file #68 for this acession.
+ ;
+ ; Call with LRAA = ien of entry in file #68
+ ;           LRAD = accession date in fileman format
+ ;           LRAN = accession number
+ ;
+ N FDA,FDAIEN,LR6802,LRDIE
+ ;
+ S LR6802=LRAD_","_LRAA_","
+ S FDAIEN(1)=LRAN
+ S FDA(2,68.02,"+1,"_LR6802,.01)=LRDFN
+ D UPDATE^DIE("","FDA(2)","FDAIEN","LRDIE(2)")
+ I $D(LRDIE(2)) D MAILALRT
+ Q
+ ;
+ ;
+MAILALRT ; Send mail message alert when FileMan DBS errors returned
+ ;
+ N J,LR68,LRCNT,LRMTXT,X,XMINSTR,XMSUB,XMTO
+ ;
+ I $D(^LRO(68,LRAA,1,LRAD,1,LRAN)) M LR68=^LRO(68,LRAA,1,LRAD,1,LRAN)
+ ;
+ S LRMTXT(1)="The following debugging information is provided to assist"
+ S LRMTXT(2)="support staff in resolving error during accessioning."
+ S LRMTXT(3)=" "
+ S LRCNT=3
+ ;
+ F J="FDA","FDAIEN","LR68","LRAA","LRAD","LRAN","LRDFN","LRDIE","LRSS","LRTSTS","LRUNQ","LRWLC","XQY","XQY0" D
+ . S X=$G(@J)
+ . I X'="" S LRCNT=LRCNT+1,LRMTXT(LRCNT)=J_"="_X
+ . F  S J=$Q(@J) Q:J=""  S LRCNT=LRCNT+1,LRMTXT(LRCNT)=J_"="_@J
+ ;
+ S XMSUB="FileMan DBS call failed during accessioning in routine LRWLST1"
+ S XMTO("G.LMI")=""
+ S XMINSTR("FROM")=.5
+ S XMINSTR("ADDR FLAGS")="R"
+ D SENDMSG^XMXAPI(DUZ,XMSUB,"LRMTXT",.XMTO,.XMINSTR)
+ Q

WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRWLST11.m

-              r613
+              r623
 LRWLST11        ;DALOI/CJS,RWF/FHS - ACCESSION SETUP ;July 19, 2006
+        ;;5.2;LAB SERVICE;**121,128,153,202,286,331,375**;Sep 27, 1994;Build 3
+        ;
 ST21    ;
         S LRTS="",LRIX=0
         F  S LRIX=$O(LRTSTS(LRWLC,LRUNQ,LRAA,LRIX)) Q:LRIX<1  D SET Q:LRUNQ
+        ;
         S LRNT=$$NOW^XLFDT
         D SCDT,SLRSS
+        ;
 COMMON  ; Setup 'in common' accession if not already setup unless it will be
         ; when tests are acessioned to the 'in common' area.
         I +LRWLC,+LRWLC'=+LRAA,$G(^LRO(68,LRWLC,1,LRAD,1,LRAN,0))=$G(LRDFN) D
         . I 'LRUNQ,$D(LRTSTS(LRWLC,LRUNQ,LRWLC)) Q
         . Q:$G(^LRO(68,LRWLC,1,LRAD,1,LRAN,.1))
         . N LRAA,LRACC,LRCDTX,LRCOMMON,LREND,LRIDT,LRNODE3,LRORDRR,LRORU3,LRQUIET,LRTJ,LRUID,X,Y
         . S (LRQUIET,LRCOMMON)=1,LRAA=+LRWLC,LRORDRR=""
         . S X=LRSS,LRCDTX=LRCDT
         . N LRCDT,LRSS
         . S LRCDT=LRCDTX,LRSS=X_U_(1+$G(LRLBLBP))
         . D STWLN^LRWLST1 Q:$G(LREND)
         . D ST2^LRWLST1 Q:$G(LREND)
         . D SCDT,SLRSS
+        ;
+        Q
+        ;
+        ;
 SCDT    ; Set collection, inverse and lab arrival date/times on accession
         N FDA,LR6802,LRDIE
         S LR6802=LRAN_","_LRAD_","_LRAA_","
         S FDA(4,68.02,LR6802,9)=LRCDT
         S FDA(4,68.02,LR6802,10)=LREAL
         I '$D(LRPHSET) S FDA(4,68.02,LR6802,12)=LRNT
         S FDA(4,68.02,LR6802,13.5)=LRIDT
         D FILE^DIE("","FDA(4)","LRDIE(4)")
         I $D(LRDIE(4)) D MAILALRT^LRWLST1
+        Q
+        ;
+        ;
 SLRSS   ;
+        ;
         S X=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)) ; change for AP
         S H8=$S($D(LRSPEC):LRSPEC,1:X)_U_$S("CYEMSPAU"[LRSS:LRACC,1:LRACC)_U_$S(LRSS="MI":LRPRAC,1:"")_U_$S(LRSS="MI":LRLLOC,1:"")_"^^"_$S(LRSS="CH":LRPRAC,1:"")_"^"_$S(LRSS="MI":$P(LRSAMP,";",1),LRSS="CH":LRLLOC,1:"")
+        ;
         I $S(LRSS="CH":1,LRSS="MI":1,1:0) D
         . I $G(LRORDRR)="R",+$G(LRRSITE("RSITE")) S $P(H8,U,9)=+LRRSITE("RSITE")_";DIC(4,"
         . I $G(LROLLOC),$G(LRORDRR)'="R" S $P(H8,U,9)=LROLLOC_";SC("
         . S $P(H8,U,10)=$S($G(LRDUZ(2)):LRDUZ(2),1:$G(DUZ(2)))
+        ;
         S ^LR(LRDFN,LRSS,LRIDT,0)=LRCDT_U_LREAL_"^^^"_H8
         I $G(LRORU3)'="" S ^LR(LRDFN,LRSS,LRIDT,"ORU")=LRORU3
+        ;
 ST3     D ST4:(LRSS="MI"),LRCCOM
+        ;
         S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3),LRPR=1
         S LRRB=0
         I LRDPF=2 S LRRB=$$GET1^DIQ(2,DFN_",",.101),LRRB=$S(LRRB'="":LRRB,1:0)
+        ;
         Q:$G(LRORDR)="P"
+        ;
         I '$D(LRTJ) D  Q
         . I $G(LRORDRR)="R",LRSS="CH",$G(LRORU3)'="",$P(LRORU3,"^")'=$P(LRORU3,"^",4) Q  ; Don't print, use label from sending facility.
         . I LRLBLBP,'$G(LRCOMMON) S LRLBL(LRAA,LRAN)=LRSN_U_LRAD_U_LRODT_U_LRRB_U_LRLLOC_U_LRACC_U_$S($D(LRORD):LRORD,1:"")
         S I=0
         F  S I=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I)) Q:I<.5  S LRTS=^(I,0) D Z
+        Q
+        ;
+        ;
 ST4     ;
         S $P(^LR(LRDFN,LRSS,LRIDT,0),U,10)=$S($D(LRNT):LRNT,1:""),$P(^(0),U,8)=LRLLOC
         ; Used to be LRSPCDSC,63.05,.9 (Word Processing field) replaces 63.05,.99
         S:$D(LRCCOM) ^LR(LRDFN,LRSS,LRIDT,99)=LRCCOM
         I '$D(LRPHSET) D
         . N DA,DIE,DR
         . S DIE="^LR("_LRDFN_",""MI"",",DA=LRIDT,DA(1)=LRDFN
         . ;S DR=.9
         . ;I '$G(LRQUIET) W:DR'=.9 !!,"Order comment:"
         . S DR=.99_$S($L($G(LRGCOM)):"///"_LRGCOM,$L($G(LRCCOM)):"//"_LRCCOM,1:"")
         . I '$G(LRQUIET) W:DR'=.99 !!,"Order comment:"
         . D ^DIE
         I '$G(LRQUIET),'$D(LRPHSET),'$D(LRGCOM) W !,"Description OK? Y//" D % G ST4:%["N"
         K DR,DIC,DIE
+        Q
+        ;
+        ;
 ST5     S I("SUBSC")=$S(I("EDIT")[11.5:26,I("EDIT")[15:27,I("EDIT")[19:28,I("EDIT")[23:29,I("EDIT")[34:30,1:-1) Q:I("SUBSC")=-1
         S I("PNTR")=$S(I("EDIT")[11.5:"^63.061A^",I("EDIT")[15:"^63.361A^",I("EDIT")[19:"^63.111A^",I("EDIT")[23:"^63.181A^",1:"^63.432A^")
         S I("N")=1+$S($D(^LR(LRDFN,"MI",LRIDT,I("SUBSC"),0)):$P(^(0),U,4),1:0),^(0)=I("PNTR")_I("N")_U_I("N"),^(I("N"),0)=I("TEST")
+        Q
+        ;
+        ;
 SET     S LRTS=LRTSTS(LRWLC,LRUNQ,LRAA,LRIX),LRIN=$P(LRTS,U,3),LRORIFN=$P(LRTS,U,4),LRTSORU=+$P(LRTS,U,6),LRTS=$P(LRTS,U,1,2),LRBACK=$P(LRTS,U,5)
+        ;
         I '$G(LRQUIET),'$D(LRPHSET) D
         . W !,$P(^LAB(60,+LRTS,0),U)
         . I $D(LRSPEC),LRSPEC D
         . . S I=$S($D(^LAB(61,+LRSPEC,0)):$P(^(0),U),1:""),J=$S($D(^LAB(62,+LRSAMP,0)):$P(^(0),U),1:"")
         . . W ?30,J W:I'=J "  ",I
+        ;
         I '$G(LRQUIET),'$D(LRPHSET),+LRTS,$O(^LAB(60,+LRTS,7,0))>0 D
         . N S
         . S DIC="^LAB(60,",DA=+LRTS,DR=7
         . D EN^DIQ H 3
         I '$G(LRQUIET),'$D(LRPHSET),+LRTS D
         . N S
         . S DIC="^LAB(60,"_(+LRTS)_",3,"
         . S DA=+$O(^LAB(60,+LRTS,3,"B",+LRSAMP,0)),DR=2
         . I DA>0,$O(^LAB(60,+LRTS,3,DA,2,0))>0 D EN^DIQ H 3
+        ;
         D ORUT
         D CAP^LRWLST12
         K LRTSTS(LRWLC,LRUNQ,LRAA,LRIX)
+        ;
         S ^LRO(69,LRODT,1,LRSN,2,LRIN,0)=LRTS_U_LRAD_U_LRAA_U_LRAN_"^^"_LRORIFN_"^^IP^L^^^^"_LRBACK
         S ^LRO(69,LRODT,1,LRSN,2,"B",+LRTS,LRIN)=""
+        ;
         ; When file 63 is enhanced to accept comments per test comments should
         ; be put there instead of field 99.
         I $O(^LRO(69,LRODT,1,LRSN,2,LRIN,1,0)) D
         . I LRSS'="CH"!($D(^LR(LRDFN,LRSS,LRIDT,0))[0) Q
         . S X=$S($D(^LR(LRDFN,LRSS,LRIDT,1,0)):$P(^(0),"^",3),1:0),I=0
         . F  S I=$O(^LRO(69,LRODT,1,LRSN,2,LRIN,1,I)) Q:I<1  S II=^(I,0) S X=X+1,^LR(LRDFN,LRSS,LRIDT,1,X,0)=II
         . S:X ^LR(LRDFN,LRSS,LRIDT,1,0)="^63.041^"_X_U_X
+        ;
 RUID    I $G(LRORU3)'="" D
         . N DA,DIE,DIC,DLAYGO,DR,X,Y
         . S DLAYGO=69
         . S DA=LRIN,DA(1)=LRSN,DA(2)=LRODT,DIC="^LRO(69,"_DA(2)_",1,"_DA(1)_",2,"
         . S DIE=DIC,DR="13////"_$P(LRORU3,U)_";14////"_$P(LRORU3,U,2)_";15////"_$P(LRORU3,U,3)_";16////"_$P(LRORU3,U,4)_";17////"_$P(LRORU3,U,5)
         . D ^DIE
+        Q
+        ;
+        ;
 %       R %:DTIME Q:%=""!(%["N")!(%["Y")  W !,"Answer 'Y' or 'N': " G %
+        ;
+        ;
 LRCCOM  ;
         N I,LRCCOM,LRTN,X
         S (I,LRTN,LRCCOM)=0 Q:LRSS'="CH"!($D(^LR(LRDFN,LRSS,LRIDT,0))[0)
         F  S I=$O(^LRO(69,LRODT,1,LRSN,6,I)) Q:I<1  I $D(^(I,0)) S X=^(0),LRCCOM=LRCCOM+1,^LR(LRDFN,LRSS,LRIDT,1,LRCCOM,0)=X
         F  S LRTN=$O(^LRO(69,LRODT,1,LRSN,2,LRTN)) Q:'LRTN  I $D(^(LRTN,0)) S X=^(0) I $P(X,"^",8),'$P(X,"^",3),$O(^(1,0)) D  ;Get comments for expanded panels
         . S I=0 F  S I=$O(^LRO(69,LRODT,1,LRSN,2,LRTN,1,I)) Q:'I  I $D(^(I,0)) S X=^(0),LRCCOM=LRCCOM+1,^LR(LRDFN,LRSS,LRIDT,1,LRCCOM,0)=X
         S:LRCCOM ^LR(LRDFN,LRSS,LRIDT,1,0)="^63.041^"_LRCCOM_U_LRCCOM
+        Q
+        ;
+        ;
 Z       L +^LRO(69.1,LRTE)
         S LRZ3=$S($D(^LRO(69.1,LRTE,1,0)):$P(^(0),U,3),1:0)
 Z1      S LRZ3=LRZ3+1 G:$D(^LRO(69.1,LRTE,1,LRZ3)) Z1
         S LRZO="^LRO(69.1,"_LRTE_",1,",LRZ1="69.11P",LRZB=+LRTS,LRIFN=LRZ3
         D Z^LRWU
         S ^LRO(69.1,LRTE,1,LRIFN,0)=+LRTS_"^"_LRLLOC_"^"_LRRB_"^"_LRDFN_"^"_LRSN_"^"_LRTJ_"^"_LRAD_"^"_LRAA_"^"_LRAN_"^"_+LROLLOC
         S ^LRO(69.1,"LRPH",LRTE,LRLLOC,LRRB,LRDFN,LRSN)=LRTJ_"^"_LRAD_"^"_LRIFN,^(LRSN,LRAA,LRAN,+LRTS)=+LRTS
         L -^LRO(69.1,LRTE)
+        Q
+        ;
+        ;
 ORUT    Q:'$G(LRTSORU)!($G(LRSS)'="CH")
         N LRTT,DLAYGO,DIC,DIE,DR,LRTST,DA,LRURG
         S DA=LRIDT,DA(1)=LRDFN
         S LRNLT=$$NLT^LRVER1(+LRTSORU) Q:+LRNLT<1  Q:$D(^LR(DA(1),LRSS,DA,"ORUT","B",LRNLT))
         S DR=".35///^S X=LRNLT",DR(1)=".35"
         S DR(1,63.04)=".35///^S X=LRNLT"
         S DR(1,63.07)=".01///^S X=LRNLT"
         S DIC="^LR("_DA(1)_","""_LRSS_""","
         S DIC(0)="MNL",DIE=DIC W:$G(LRDBUG) !,LRNLT
         D ^DIE
+        ;
 ORUT2   S LRTST=$P($G(^LAM($O(^LAM("E",LRNLT,0)),0)),U) Q:LRTST=""!('$G(LR696IEN))
         Q:'($D(^LRO(69.6,LR696IEN,0))#2)!($D(^LRO(69.6,LR696IEN,2,"C",LRNLT)))
         S:'$D(^LRO(69.6,LR696IEN,2,0)) ^(0)="^69.64A^"
         S DLAYGO=69.6
         K DIC,DIE,DA,DR,DA
         S DA=LR696IEN
         S LRURG="R",LRURG=$S($L($P($G(^LAB(62.05,+$P(LRTS,U,2),0)),U,4)):$P(^(0),U,4),1:LRURG)
         S (DIE,DIC)="^LRO(69.6,",DIC(0)="LM"
         S DR=20_"///"_LRTST_";",DR(1,69.6)="20///"_LRTST_";"
         S DR(2,69.64)=".01///"_LRTST_";1///"_LRNLT_";4///"_LRURG_";5////160;8///"_LRNT_";9///"_LRUID
         D ^DIE
+        Q
+        ;
+        ;
 SICA    ; Check accessions 'in common' and setup reference to this accession
         N FDA,LR6802,LRDIE,LRAA
         S LRX=$P($G(^LRO(68,LRWLC,1,LRAD,1,LRAN,.2)),"^"),LRAA=0
         F  S LRAA=$O(LRTSTS(LRWLC,LRUNQ,LRAA)) Q:LRAA<1  I LRWLC'=LRAA D
         . S LR6802=LRAN_","_LRAD_","_LRAA_","
         . S FDA(5,68.02,LR6802,15.1)=LRX
         . D FILE^DIE("","FDA(5)","LRDIE(5)")
         . I $D(LRDIE(5)) D MAILALRT^LRWLST1
+        Q
+LRWLST11 ;DALOI/CJS,RWF/FHS - ACCESSION SETUP ;July 19, 2006
+ ;;5.2;LAB SERVICE;**121,128,153,202,286,331**;Sep 27, 1994;Build 7
+ ;
+ST21 ;
+ S LRTS="",LRIX=0
+ F  S LRIX=$O(LRTSTS(LRWLC,LRUNQ,LRAA,LRIX)) Q:LRIX<1  D SET Q:LRUNQ
+ ;
+ S LRNT=$$NOW^XLFDT
+ D SCDT,SLRSS
+ ;
+COMMON ; Setup 'in common' accession if not already setup unless it will be
+ ; when tests are acessioned to the 'in common' area.
+ I +LRWLC,+LRWLC'=+LRAA,$G(^LRO(68,LRWLC,1,LRAD,1,LRAN,0))=$G(LRDFN) D
+ . I $D(LRTSTS(LRWLC,LRUNQ,LRWLC)) Q
+ . Q:$G(^LRO(68,LRWLC,1,LRAD,1,LRAN,.1))
+ . N LRAA,LRACC,LRCDTX,LRCOMMON,LREND,LRIDT,LRNODE3,LRORDRR,LRORU3,LRQUIET,LRTJ,LRUID,X,Y
+ . S (LRQUIET,LRCOMMON)=1,LRAA=+LRWLC,LRORDRR=""
+ . S X=LRSS,LRCDTX=LRCDT
+ . N LRCDT,LRSS
+ . S LRCDT=LRCDTX,LRSS=X_U_(1+$G(LRLBLBP))
+ . D STWLN^LRWLST1 Q:$G(LREND)
+ . D ST2^LRWLST1 Q:$G(LREND)
+ . D SCDT,SLRSS
+ ;
+ Q
+ ;
+ ;
+SCDT ; Set collection, inverse and lab arrival date/times on accession
+ N FDA,LR6802,LRDIE
+ S LR6802=LRAN_","_LRAD_","_LRAA_","
+ S FDA(4,68.02,LR6802,9)=LRCDT
+ S FDA(4,68.02,LR6802,10)=LREAL
+ I '$D(LRPHSET) S FDA(4,68.02,LR6802,12)=LRNT
+ S FDA(4,68.02,LR6802,13.5)=LRIDT
+ D FILE^DIE("","FDA(4)","LRDIE(4)")
+ I $D(LRDIE(4)) D MAILALRT^LRWLST1
+ Q
+ ;
+ ;
+SLRSS ;
+ ;
+ S X=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)) ; change for AP
+ S H8=$S($D(LRSPEC):LRSPEC,1:X)_U_$S("CYEMSPAU"[LRSS:LRACC,1:LRACC)_U_$S(LRSS="MI":LRPRAC,1:"")_U_$S(LRSS="MI":LRLLOC,1:"")_"^^"_$S(LRSS="CH":LRPRAC,1:"")_"^"_$S(LRSS="MI":$P(LRSAMP,";",1),LRSS="CH":LRLLOC,1:"")
+ ;
+ I $S(LRSS="CH":1,LRSS="MI":1,1:0) D
+ . I $G(LRORDRR)="R",+$G(LRRSITE("RSITE")) S $P(H8,U,9)=+LRRSITE("RSITE")_";DIC(4,"
+ . I $G(LROLLOC),$G(LRORDRR)'="R" S $P(H8,U,9)=LROLLOC_";SC("
+ . S $P(H8,U,10)=$S($G(LRDUZ(2)):LRDUZ(2),1:$G(DUZ(2)))
+ ;
+ S ^LR(LRDFN,LRSS,LRIDT,0)=LRCDT_U_LREAL_"^^^"_H8
+ I $G(LRORU3)'="" S ^LR(LRDFN,LRSS,LRIDT,"ORU")=LRORU3
+ ;
+ST3 D ST4:(LRSS="MI"),LRCCOM
+ ;
+ S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3),LRPR=1
+ S LRRB=0
+ I LRDPF=2 S LRRB=$$GET1^DIQ(2,DFN_",",.101),LRRB=$S(LRRB'="":LRRB,1:0)
+ ;
+ Q:$G(LRORDR)="P"
+ ;
+ I '$D(LRTJ) D  Q
+ . I $G(LRORDRR)="R",LRSS="CH",$G(LRORU3)'="",$P(LRORU3,"^")'=$P(LRORU3,"^",4) Q  ; Don't print, use label from sending facility.
+ . I LRLBLBP,'$G(LRCOMMON) S LRLBL(LRAA,LRAN)=LRSN_U_LRAD_U_LRODT_U_LRRB_U_LRLLOC_U_LRACC_U_$S($D(LRORD):LRORD,1:"")
+ S I=0
+ F  S I=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I)) Q:I<.5  S LRTS=^(I,0) D Z
+ Q
+ ;
+ ;
+ST4 ;
+ S $P(^LR(LRDFN,LRSS,LRIDT,0),U,10)=$S($D(LRNT):LRNT,1:""),$P(^(0),U,8)=LRLLOC
+ ; Used to be LRSPCDSC,63.05,.9 (Word Processing field) replaces 63.05,.99
+ S:$D(LRCCOM) ^LR(LRDFN,LRSS,LRIDT,99)=LRCCOM
+ I '$D(LRPHSET) D
+ . N DA,DIE,DR
+ . S DIE="^LR("_LRDFN_",""MI"",",DA=LRIDT,DA(1)=LRDFN
+ . ;S DR=.9
+ . ;I '$G(LRQUIET) W:DR'=.9 !!,"Order comment:"
+ . S DR=.99_$S($L($G(LRGCOM)):"///"_LRGCOM,$L($G(LRCCOM)):"//"_LRCCOM,1:"")
+ . I '$G(LRQUIET) W:DR'=.99 !!,"Order comment:"
+ . D ^DIE
+ I '$G(LRQUIET),'$D(LRPHSET),'$D(LRGCOM) W !,"Description OK? Y//" D % G ST4:%["N"
+ K DR,DIC,DIE
+ Q
+ ;
+ ;
+ST5 S I("SUBSC")=$S(I("EDIT")[11.5:26,I("EDIT")[15:27,I("EDIT")[19:28,I("EDIT")[23:29,I("EDIT")[34:30,1:-1) Q:I("SUBSC")=-1
+ S I("PNTR")=$S(I("EDIT")[11.5:"^63.061A^",I("EDIT")[15:"^63.361A^",I("EDIT")[19:"^63.111A^",I("EDIT")[23:"^63.181A^",1:"^63.432A^")
+ S I("N")=1+$S($D(^LR(LRDFN,"MI",LRIDT,I("SUBSC"),0)):$P(^(0),U,4),1:0),^(0)=I("PNTR")_I("N")_U_I("N"),^(I("N"),0)=I("TEST")
+ Q
+ ;
+ ;
+SET S LRTS=LRTSTS(LRWLC,LRUNQ,LRAA,LRIX),LRIN=$P(LRTS,U,3),LRORIFN=$P(LRTS,U,4),LRTSORU=+$P(LRTS,U,6),LRTS=$P(LRTS,U,1,2),LRBACK=$P(LRTS,U,5)
+ ;
+ I '$G(LRQUIET),'$D(LRPHSET) D
+ . W !,$P(^LAB(60,+LRTS,0),U)
+ . I $D(LRSPEC),LRSPEC D
+ . . S I=$S($D(^LAB(61,+LRSPEC,0)):$P(^(0),U),1:""),J=$S($D(^LAB(62,+LRSAMP,0)):$P(^(0),U),1:"")
+ . . W ?30,J W:I'=J "  ",I
+ ;
+ I '$G(LRQUIET),'$D(LRPHSET),+LRTS,$O(^LAB(60,+LRTS,7,0))>0 D
+ . N S
+ . S DIC="^LAB(60,",DA=+LRTS,DR=7
+ . D EN^DIQ H 3
+ I '$G(LRQUIET),'$D(LRPHSET),+LRTS D
+ . N S
+ . S DIC="^LAB(60,"_(+LRTS)_",3,"
+ . S DA=+$O(^LAB(60,+LRTS,3,"B",+LRSAMP,0)),DR=2
+ . I DA>0,$O(^LAB(60,+LRTS,3,DA,2,0))>0 D EN^DIQ H 3
+ ;
+ D ORUT
+ D CAP^LRWLST12
+ K LRTSTS(LRWLC,LRUNQ,LRAA,LRIX)
+ ;
+ S ^LRO(69,LRODT,1,LRSN,2,LRIN,0)=LRTS_U_LRAD_U_LRAA_U_LRAN_"^^"_LRORIFN_"^^IP^L^^^^"_LRBACK
+ S ^LRO(69,LRODT,1,LRSN,2,"B",+LRTS,LRIN)=""
+ ;
+ ; When file 63 is enhanced to accept comments per test comments should
+ ; be put there instead of field 99.
+ I $O(^LRO(69,LRODT,1,LRSN,2,LRIN,1,0)) D
+ . I LRSS'="CH"!($D(^LR(LRDFN,LRSS,LRIDT,0))[0) Q
+ . S X=$S($D(^LR(LRDFN,LRSS,LRIDT,1,0)):$P(^(0),"^",3),1:0),I=0
+ . F  S I=$O(^LRO(69,LRODT,1,LRSN,2,LRIN,1,I)) Q:I<1  S II=^(I,0) S X=X+1,^LR(LRDFN,LRSS,LRIDT,1,X,0)=II
+ . S:X ^LR(LRDFN,LRSS,LRIDT,1,0)="^63.041^"_X_U_X
+ ;
+RUID I $G(LRORU3)'="" D
+ . N DA,DIE,DIC,DLAYGO,DR,X,Y
+ . S DLAYGO=69
+ . S DA=LRIN,DA(1)=LRSN,DA(2)=LRODT,DIC="^LRO(69,"_DA(2)_",1,"_DA(1)_",2,"
+ . S DIE=DIC,DR="13////"_$P(LRORU3,U)_";14////"_$P(LRORU3,U,2)_";15////"_$P(LRORU3,U,3)_";16////"_$P(LRORU3,U,4)_";17////"_$P(LRORU3,U,5)
+ . D ^DIE
+ Q
+ ;
+ ;
+% R %:DTIME Q:%=""!(%["N")!(%["Y")  W !,"Answer 'Y' or 'N': " G %
+ ;
+ ;
+LRCCOM ;
+ N I,LRCCOM,LRTN,X
+ S (I,LRTN,LRCCOM)=0 Q:LRSS'="CH"!($D(^LR(LRDFN,LRSS,LRIDT,0))[0)
+ F  S I=$O(^LRO(69,LRODT,1,LRSN,6,I)) Q:I<1  I $D(^(I,0)) S X=^(0),LRCCOM=LRCCOM+1,^LR(LRDFN,LRSS,LRIDT,1,LRCCOM,0)=X
+ F  S LRTN=$O(^LRO(69,LRODT,1,LRSN,2,LRTN)) Q:'LRTN  I $D(^(LRTN,0)) S X=^(0) I $P(X,"^",8),'$P(X,"^",3),$O(^(1,0)) D  ;Get comments for expanded panels
+ . S I=0 F  S I=$O(^LRO(69,LRODT,1,LRSN,2,LRTN,1,I)) Q:'I  I $D(^(I,0)) S X=^(0),LRCCOM=LRCCOM+1,^LR(LRDFN,LRSS,LRIDT,1,LRCCOM,0)=X
+ S:LRCCOM ^LR(LRDFN,LRSS,LRIDT,1,0)="^63.041^"_LRCCOM_U_LRCCOM
+ Q
+ ;
+ ;
+Z L +^LRO(69.1,LRTE)
+ S LRZ3=$S($D(^LRO(69.1,LRTE,1,0)):$P(^(0),U,3),1:0)
+Z1 S LRZ3=LRZ3+1 G:$D(^LRO(69.1,LRTE,1,LRZ3)) Z1
+ S LRZO="^LRO(69.1,"_LRTE_",1,",LRZ1="69.11P",LRZB=+LRTS,LRIFN=LRZ3
+ D Z^LRWU
+ S ^LRO(69.1,LRTE,1,LRIFN,0)=+LRTS_"^"_LRLLOC_"^"_LRRB_"^"_LRDFN_"^"_LRSN_"^"_LRTJ_"^"_LRAD_"^"_LRAA_"^"_LRAN_"^"_+LROLLOC
+ S ^LRO(69.1,"LRPH",LRTE,LRLLOC,LRRB,LRDFN,LRSN)=LRTJ_"^"_LRAD_"^"_LRIFN,^(LRSN,LRAA,LRAN,+LRTS)=+LRTS
+ L -^LRO(69.1,LRTE)
+ Q
+ ;
+ ;
+ORUT Q:'$G(LRTSORU)!($G(LRSS)'="CH")
+ N LRTT,DLAYGO,DIC,DIE,DR,LRTST,DA,LRURG
+ S DA=LRIDT,DA(1)=LRDFN
+ S LRNLT=$$NLT^LRVER1(+LRTSORU) Q:+LRNLT<1  Q:$D(^LR(DA(1),LRSS,DA,"ORUT","B",LRNLT))
+ S DR=".35///^S X=LRNLT",DR(1)=".35"
+ S DR(1,63.04)=".35///^S X=LRNLT"
+ S DR(1,63.07)=".01///^S X=LRNLT"
+ S DIC="^LR("_DA(1)_","""_LRSS_""","
+ S DIC(0)="MNL",DIE=DIC W:$G(LRDBUG) !,LRNLT
+ D ^DIE
+ ;
+ORUT2 S LRTST=$P($G(^LAM($O(^LAM("E",LRNLT,0)),0)),U) Q:LRTST=""!('$G(LR696IEN))
+ Q:'($D(^LRO(69.6,LR696IEN,0))#2)!($D(^LRO(69.6,LR696IEN,2,"C",LRNLT)))
+ S:'$D(^LRO(69.6,LR696IEN,2,0)) ^(0)="^69.64A^"
+ S DLAYGO=69.6
+ K DIC,DIE,DA,DR,DA
+ S DA=LR696IEN
+ S LRURG="R",LRURG=$S($L($P($G(^LAB(62.05,+$P(LRTS,U,2),0)),U,4)):$P(^(0),U,4),1:LRURG)
+ S (DIE,DIC)="^LRO(69.6,",DIC(0)="LM"
+ S DR=20_"///"_LRTST_";",DR(1,69.6)="20///"_LRTST_";"
+ S DR(2,69.64)=".01///"_LRTST_";1///"_LRNLT_";4///"_LRURG_";5////160;8///"_LRNT_";9///"_LRUID
+ D ^DIE
+ Q
+ ;
+ ;
+SICA ; Check accessions 'in common' and setup reference to this accession
+ N FDA,LR6802,LRDIE,LRAA
+ S LRX=$P($G(^LRO(68,LRWLC,1,LRAD,1,LRAN,.2)),"^"),LRAA=0
+ F  S LRAA=$O(LRTSTS(LRWLC,LRUNQ,LRAA)) Q:LRAA<1  I LRWLC'=LRAA D
+ . S LR6802=LRAN_","_LRAD_","_LRAA_","
+ . S FDA(5,68.02,LR6802,15.1)=LRX
+ . D FILE^DIE("","FDA(5)","LRDIE(5)")
+ . I $D(LRDIE(5)) D MAILALRT^LRWLST1
+ Q

WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRWOMEN.m

-              r613
+              r623
 LRWOMEN ;DALOI/CYM/FT/CKA - LINK TO WOMEN'S HEALTH PROGRAM ;10/22/04  13:14
+        ;;5.2;LAB SERVICE;**231,248,311,324,365**;Sep 27, 1994;Build 9
+        ;
         ;Reference to CREATE^WVLRLINK supported by IA #2772
         ;Reference to DELETE^WVLRLINK supported by IA #2772
+        ;Reference to CREATE^WVLABCHK supported by IA #4525
+        ;
+ADD     ; From DD 63.08,.11 and 63.09,.11
+        Q:+$G(LRDPF)'=2
+        Q:'$D(LRSS)
+        Q:$P(^LR(LRDFN,LRSS,LRI,0),U,11)']""
+        Q:$G(SEX)'["F"
+        Q:$T(CREATE^WVLRLINK)']""
+        D CREATE^WVLRLINK(DFN,LRDFN,LRI,$G(LRA),LRSS)
+        Q
+        ;
+        ;
+DEL     ; From LRAPM
         Q:$G(SEX)'["F"
+        Q:+$G(LRDPF)'=2
+        Q:'$D(LRSS)
+        Q:$P(^LR(LRDFN,LRSS,LRI,0),U,11)]""
         Q:$T(DELETE^WVLRLINK)']""
+        D DELETE^WVLRLINK(DFN,LRDFN,LRI,X,LRSS)
+        Q
+        ;
+        ;
+MOVE    ; From LRAPMV
+        ; no longer used after LR*5.2*259
+        Q
+        ;
+        ;
 SNOMED  ; From DD 63.08,10 and 63.09,10
         Q:+$G(LRDPF)'=2
         Q:'$D(LRSS)
         Q:$P(^LR(LRDFN,LRSS,LRI,0),U,11)=""
         Q:$G(SEX)'["F"
         Q:$T(CREATE^WVLABCHK)']""
         D CREATE^WVLABCHK(DFN,LRDFN,LRI,$G(LRA),LRSS)
+        Q
+LRWOMEN ;DALOI/CYM/FT -  LINK TO WOMEN'S HEALTH PROGRAM ;10/22/04  13:14
+ ;;5.2;LAB SERVICE;**231,248,311,324**;Sep 27, 1994
+ ;
+ ;Reference to CREATE^WVLRLINK supported by IA #2772
+ ;Reference to DELETE^WVLRLINK supported by IA #2772
+ ;Reference to MOVE^WVLRLINK supported by IA #2772
+ ;Reference to ^XPDUTL supported by IA #10141
+ ;Reference to ^ORB3LAB supported by IA #4287
+ ;Reference to CREATE^WVLABCHK supported by IA #4525
+ ;
+ADD ; From DD 63.08,.11 and 63.09,.11
+ Q:+$G(LRDPF)'=2
+ Q:'$D(LRSS)
+ Q:$P(^LR(LRDFN,LRSS,LRI,0),U,11)']""
+ I $$PATCH^XPDUTL("OR*3.0*210") D
+ .Q:$G(LRAPOLDF)=1
+ .D LAB^ORB3LAB(DFN,LRDFN,LRI,$G(LRA),LRSS)
+ Q:$G(SEX)'["F"
+ Q:$T(CREATE^WVLRLINK)']""
+ D CREATE^WVLRLINK(DFN,LRDFN,LRI,$G(LRA),LRSS)
+ Q
+DEL ; From LRAPM
+ Q:$G(SEX)'["F"
+ Q:+$G(LRDPF)'=2
+ Q:'$D(LRSS)
+ Q:$P(^LR(LRDFN,LRSS,LRI,0),U,11)]""
+ Q:$T(DELETE^WVLRLINK)']""
+ D DELETE^WVLRLINK(DFN,LRDFN,LRI,X,LRSS)
+ Q
+MOVE ; From LRAPMV
+ ; no longer used after LR*5.2*259
+ Q
+SNOMED ; From DD 63.08,10 and 63.09,10
+ Q:+$G(LRDPF)'=2
+ Q:'$D(LRSS)
+ Q:$P(^LR(LRDFN,LRSS,LRI,0),U,11)=""
+ Q:$G(SEX)'["F"
+ Q:$T(CREATE^WVLABCHK)']""
+ D CREATE^WVLABCHK(DFN,LRDFN,LRI,$G(LRA),LRSS)
+ Q

Note: See TracChangeset for help on using the changeset viewer.

Context Navigation

Changeset 623 for WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS

Legend:

Download in other formats: