Released LR*5.2*512 SEQ #422 Extracted from mail message **KIDS**:LR*5.2*512^ **INSTALL NAME** LR*5.2*512 "BLD",11189,0) LR*5.2*512^LAB SERVICE^0^3180927^y "BLD",11189,1,0) ^^4^4^3180823^ "BLD",11189,1,1,0) This patch addresses one (1) VistA Laboratory issue: "BLD",11189,1,2,0) "BLD",11189,1,3,0) The status for a lab order in CPRS displays as "active" when the status "BLD",11189,1,4,0) should display as "complete". "BLD",11189,4,0) ^9.64PA^^ "BLD",11189,6.3) 7 "BLD",11189,"ABPKG") n "BLD",11189,"KRN",0) ^9.67PA^779.2^20 "BLD",11189,"KRN",.4,0) .4 "BLD",11189,"KRN",.401,0) .401 "BLD",11189,"KRN",.402,0) .402 "BLD",11189,"KRN",.403,0) .403 "BLD",11189,"KRN",.5,0) .5 "BLD",11189,"KRN",.84,0) .84 "BLD",11189,"KRN",3.6,0) 3.6 "BLD",11189,"KRN",3.8,0) 3.8 "BLD",11189,"KRN",9.2,0) 9.2 "BLD",11189,"KRN",9.8,0) 9.8 "BLD",11189,"KRN",9.8,"NM",0) ^9.68A^4^4 "BLD",11189,"KRN",9.8,"NM",1,0) LRVER1^^0^B54953290 "BLD",11189,"KRN",9.8,"NM",2,0) LRVER3A^^0^B124646001 "BLD",11189,"KRN",9.8,"NM",3,0) LR7OB3^^0^B41472620 "BLD",11189,"KRN",9.8,"NM",4,0) LRVR1^^0^B62383256 "BLD",11189,"KRN",9.8,"NM","B","LR7OB3",3) "BLD",11189,"KRN",9.8,"NM","B","LRVER1",1) "BLD",11189,"KRN",9.8,"NM","B","LRVER3A",2) "BLD",11189,"KRN",9.8,"NM","B","LRVR1",4) "BLD",11189,"KRN",19,0) 19 "BLD",11189,"KRN",19.1,0) 19.1 "BLD",11189,"KRN",101,0) 101 "BLD",11189,"KRN",409.61,0) 409.61 "BLD",11189,"KRN",771,0) 771 "BLD",11189,"KRN",779.2,0) 779.2 "BLD",11189,"KRN",870,0) 870 "BLD",11189,"KRN",8989.51,0) 8989.51 "BLD",11189,"KRN",8989.52,0) 8989.52 "BLD",11189,"KRN",8994,0) 8994 "BLD",11189,"KRN","B",.4,.4) "BLD",11189,"KRN","B",.401,.401) "BLD",11189,"KRN","B",.402,.402) "BLD",11189,"KRN","B",.403,.403) "BLD",11189,"KRN","B",.5,.5) "BLD",11189,"KRN","B",.84,.84) "BLD",11189,"KRN","B",3.6,3.6) "BLD",11189,"KRN","B",3.8,3.8) "BLD",11189,"KRN","B",9.2,9.2) "BLD",11189,"KRN","B",9.8,9.8) "BLD",11189,"KRN","B",19,19) "BLD",11189,"KRN","B",19.1,19.1) "BLD",11189,"KRN","B",101,101) "BLD",11189,"KRN","B",409.61,409.61) "BLD",11189,"KRN","B",771,771) "BLD",11189,"KRN","B",779.2,779.2) "BLD",11189,"KRN","B",870,870) "BLD",11189,"KRN","B",8989.51,8989.51) "BLD",11189,"KRN","B",8989.52,8989.52) "BLD",11189,"KRN","B",8994,8994) "BLD",11189,"QDEF") ^^^^NO^^^^NO^^NO "BLD",11189,"QUES",0) ^9.62^^ "BLD",11189,"REQB",0) ^9.611^3^3 "BLD",11189,"REQB",1,0) LR*5.2*461^2 "BLD",11189,"REQB",2,0) LR*5.2*462^2 "BLD",11189,"REQB",3,0) LR*5.2*440^2 "BLD",11189,"REQB","B","LR*5.2*440",3) "BLD",11189,"REQB","B","LR*5.2*461",1) "BLD",11189,"REQB","B","LR*5.2*462",2) "MBREQ") 0 "PKG",26,-1) 1^1 "PKG",26,0) LAB SERVICE^LR^CORE LAB SYSTEM "PKG",26,20,0) ^9.402P^1^1 "PKG",26,20,1,0) 2^^LRXDRPT "PKG",26,20,1,1) "PKG",26,20,"B",2,1) "PKG",26,22,0) ^9.49I^1^1 "PKG",26,22,1,0) 5.2^2940927^2981028^66481 "PKG",26,22,1,"PAH",1,0) 512^3180927 "PKG",26,22,1,"PAH",1,1,0) ^^4^4^3180927 "PKG",26,22,1,"PAH",1,1,1,0) This patch addresses one (1) VistA Laboratory issue: "PKG",26,22,1,"PAH",1,1,2,0) "PKG",26,22,1,"PAH",1,1,3,0) The status for a lab order in CPRS displays as "active" when the status "PKG",26,22,1,"PAH",1,1,4,0) should display as "complete". "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") NO "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") NO "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") NO "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 4 "RTN","LR7OB3") 0^3^B41472620^B27184019 "RTN","LR7OB3",1,0) LR7OB3 ;DALOI/DCM/JAH - Build message, backdoor from Lab order #;Sep 27, 2018@10:00:00 "RTN","LR7OB3",2,0) ;;5.2;LAB SERVICE;**121,187,272,291,462,512**;Sep 27, 1994;Build 7 "RTN","LR7OB3",3,0) 69 K ^TMP("LRX",$J) "RTN","LR7OB3",4,0) D 69^LR7OB69(ODT,SN) Q:'$D(^TMP("LRX",$J,69)) G OUT:'$D(DFN) D:LRFIRST FIRST^LR7OB0 S LRFIRST=0 "RTN","LR7OB3",5,0) SNEAK ; "RTN","LR7OB3",6,0) N Y,Y9,Y10,Y11,GRP,L1,L2,L3,END,LROR100 "RTN","LR7OB3",7,0) S IFN=0 F S IFN=$O(^TMP("LRX",$J,69,IFN)) Q:IFN<1 S (COBR,COBX)=0 D "RTN","LR7OB3",8,0) . I $O(^TMP("LRX",$J,69,IFN,68,0)) S Z=^TMP("LRX",$J,69,IFN,68) D Q "RTN","LR7OB3",9,0) .. S IFN1=0 F S IFN1=$O(^TMP("LRX",$J,69,IFN,68,IFN1)) Q:IFN1<1 S Z1=^TMP("LRX",$J,69,IFN,68,IFN1) D "RTN","LR7OB3",10,0) ... S (Y9,Y10,Y11)="" I $P($G(^LAB(60,+Z1,64)),"^") S Y9=$P(^(64),"^"),Y10=$P(^LAM(Y9,0),"^"),Y9=$P(^(0),"^",2),Y11="99NLT" "RTN","LR7OB3",11,0) ... S X1=$$UVID^LR7OU0($P(Z1,"^"),$P(^TMP("LRX",$J,69),"^",10),Y9,Y11,Y10,.MSG,$G(SS)) "RTN","LR7OB3",12,0) ... S X2=$$HL7DT^LR7OU0($P(Z,"^",4)) ;Obs Start date "RTN","LR7OB3",13,0) ... S X3=$$ACTCODE^LR7OU0($P(^TMP("LRX",$J,69),"^",4)) ;Specimen Act Code "RTN","LR7OB3",14,0) ... S X4=$$HL7DT^LR7OU0($P(Z,"^",5)) ;Specimen Received D/T "RTN","LR7OB3",15,0) ... S X5=$$SAMP^LR7OU0($P(^TMP("LRX",$J,69),"^",3),$P(^TMP("LRX",$J,69),"^",10)) ;Specimen Source "RTN","LR7OB3",16,0) ... S X6=$P(Z,"^",3) ;Filler Fld 1 (Accession) "RTN","LR7OB3",17,0) ... S X7=$$HL7DT^LR7OU0($P(Z,"^",6)) ;Results rpt/Sts Change D/T "RTN","LR7OB3",18,0) ... ;CPRS order number: "RTN","LR7OB3",19,0) ... S LROR100=$P($G(^TMP("LRX",$J,69,IFN)),"^",7) "RTN","LR7OB3",20,0) ... ; "RTN","LR7OB3",21,0) ... ;Check to see if the CPRS order number matches the ORC order number "RTN","LR7OB3",22,0) ... I $P($P(@MSG@(ORCMSG),"|",3),"^")'=LROR100 D "RTN","LR7OB3",23,0) .... N LRORC "RTN","LR7OB3",24,0) .... S LRORC=$P(@MSG@(ORCMSG),"|",3) "RTN","LR7OB3",25,0) .... S $P(LRORC,"^")=LROR100 "RTN","LR7OB3",26,0) .... S $P(@MSG@(ORCMSG),"|",3)=LRORC "RTN","LR7OB3",27,0) ... S (GRP,END)=0 "RTN","LR7OB3",28,0) ... I '$G(CORRECT),$P(Z,"^",6) S GRP=1 "RTN","LR7OB3",29,0) ... ;LR*5.2*512 change on line below so that status of each panel and/or "RTN","LR7OB3",30,0) ... ;atomic test is evaluated: added $P(Z1,"^",4):"F" "RTN","LR7OB3",31,0) ... ;Variables: "RTN","LR7OB3",32,0) ... ; Z = (1) Lab order number ^ (2) LRDFN ^ (3) accession ^ (4) draw time ^ "RTN","LR7OB3",33,0) ... ; (5) lab arrival time ^ (6) date/time results available (i.e. accession complete date) "RTN","LR7OB3",34,0) ... ; (7) inverse date (i.e. file 63 subscript corresponding to this accession) "RTN","LR7OB3",35,0) ... ; "RTN","LR7OB3",36,0) ... ; Z1 = (1) test number ^ (2) test urgency ^ (3) technologist ^ (4) complete date/time ^ "RTN","LR7OB3",37,0) ... ; "RTN","LR7OB3",38,0) ... S X8=$S($G(CORRECT):"C",$P(Z,"^",6):$S(GRP:"F",1:"I"),$P(Z1,"^",4):"F",$P(Z,"^",5):"I",1:"O") ;Result Status "RTN","LR7OB3",39,0) ... D AX8 "RTN","LR7OB3",40,0) ... S X10=$P(^TMP("LRX",$J,69),"^",7),$P(@MSG@(3),"|",4)=X10 ;Routing Location "RTN","LR7OB3",41,0) ... S X9="^^^^^"_$$URG^LR7OU0($P(^TMP("LRX",$J,69,IFN),"^",2)) "RTN","LR7OB3",42,0) ... I $O(LINK(0)) S CTR=CTR+1 D NTE^LR7OU01(2,"L","LINK(",CTR) K LINK "RTN","LR7OB3",43,0) ... I $O(^TMP("LRX",$J,69,IFN,"NC",0)) S CTR=CTR+1 D NTE^LR7OU01("","L","^TMP(""LRX"",$J,69,"_IFN_",""NC"",",CTR) "RTN","LR7OB3",44,0) ... I CONTROL'="SN" S CTR=CTR+1 D NTE^LR7OU01("","P","^TMP(""LRX"",$J,69,"_IFN_",""N"",",CTR) "RTN","LR7OB3",45,0) ... I CONTROL'="SN" S CTR=CTR+1 D NTE^LR7OU01("","P","^TMP(""LRX"",$J,69,""N"",",CTR) "RTN","LR7OB3",46,0) ... S CTR=CTR+1,COBR=COBR+1,OBRMSG=CTR D OBR^LR7OU01(CTR) "RTN","LR7OB3",47,0) ... S CTR=CTR+1 D SDG1^LRBEBA2(IFN,.CTR,.MSG) "RTN","LR7OB3",48,0) ... I CONTROL="SN" S CTR=CTR+1 D NTE^LR7OU01("","P","^TMP(""LRX"",$J,69,"_IFN_",""N"",",CTR) "RTN","LR7OB3",49,0) ... I CONTROL="SN" S CTR=CTR+1 D NTE^LR7OU01("","P","^TMP(""LRX"",$J,69,""N"",",CTR) "RTN","LR7OB3",50,0) .. S IFN1=0 F S IFN1=$O(^TMP("LRX",$J,69,IFN,63,IFN1)) Q:IFN1<1 S Z1=^TMP("LRX",$J,69,IFN,63,IFN1) D "RTN","LR7OB3",51,0) ... S X1=$S($L($P(Z1,"^",8)):$P(Z1,"^",8),1:"ST") ;Value type "RTN","LR7OB3",52,0) ... S X2=$$UVID^LR7OU0($P(Z1,"^"),$P(^TMP("LRX",$J,69),"^",10),$P(Z1,"^",9),$P(Z1,"^",11),$P(Z1,"^",10),.MSG,$G(SS)) "RTN","LR7OB3",53,0) ... S X3=$P(Z1,"^",7) ;Obs SubID "RTN","LR7OB3",54,0) ... S X4=$P(Z1,"^",2) S:$L($P(Z1,"^",9))&(MSG["LRAP") X4=$P(Z1,"^",9)_"^"_$P(Z1,"^",2)_"^"_$P(Z1,"^",10) ;Value "RTN","LR7OB3",55,0) ... S X5=$P(Z1,"^",4) ;Units "RTN","LR7OB3",56,0) ... S X6=$P(Z1,"^",5) ;Ref Ranges "RTN","LR7OB3",57,0) ... S X7=$$FLAG^LR7OU0($P(Z1,"^",3)) ;Flag "RTN","LR7OB3",58,0) ... S (GRP,END)=0 "RTN","LR7OB3",59,0) ... I '$G(CORRECT),$P(Z1,"^",6)="F"!($P(Z,"^",6)) S GRP=1 "RTN","LR7OB3",60,0) ... S X8=$S($G(CORRECT):"C",$P(Z1,"^",6)="F"!($P(Z,"^",6)):$S(GRP:"F",1:"I"),$L($P(Z1,"^",6)):$S($P(Z1,"^",6)'="F":$P(Z1,"^",6),1:"R"),1:"R") "RTN","LR7OB3",61,0) ... S $P(@MSG@(OBRMSG),"|",26)=X8 ;Result Status "RTN","LR7OB3",62,0) ... I @MSG@(OBRMSG)'?.E1"|",$O(@MSG@(OBRMSG,0))]"" S @MSG@(OBRMSG)=@MSG@(OBRMSG)_"|" ;RLM "RTN","LR7OB3",63,0) ... ;LR*5.2*512 commenting out line below "RTN","LR7OB3",64,0) ... ;because a single result status should not update "RTN","LR7OB3",65,0) ... ;the overall order status in the ORC segment "RTN","LR7OB3",66,0) ... ;D AX8 "RTN","LR7OB3",67,0) ... I $L($P(Z1,"^",18)) S X=$P(@MSG@(ORCMSG),"|",4),Y=$P(X,"^",2),X=$P(X,"^")_$P(Z1,"^",18) S $P(@MSG@(ORCMSG),"|",4)=X_"^"_Y ;Append 63 ptr to placer ID "RTN","LR7OB3",68,0) ... I "SPCYEM"[$P($G(X),";",4)&($L($P(X,";",5))) S $P(@MSG@(ORCMSG),"|",4)=X_"^LRAP" ;;* added to correct result update to CPRS where the package reference was not being updated properly for AP results "RTN","LR7OB3",69,0) ... ; X=ORD#;LRODT;LRSN;LRSS;LRIDT, indirect set of ^TMP("LRAP",$J "RTN","LR7OB3",70,0) ... S X10=$P(Z1,"^",14) ;Theraputic flag "RTN","LR7OB3",71,0) ... S X11=$P(Z1,"^",12) ;Verified by "RTN","LR7OB3",72,0) ... S CTR=CTR+1,COBX=COBX+1 D OBX^LR7OU01(CTR) "RTN","LR7OB3",73,0) .. I $O(^TMP("LRX",$J,69,IFN,63,0)),$O(^("N",0)) S CTR=CTR+1 D NTE^LR7OU01("","L","^TMP(""LRX"",$J,69,"_IFN_",63,""N"",",CTR) "RTN","LR7OB3",74,0) . ; "RTN","LR7OB3",75,0) . ;Note to anyone researching this routine in the future: "RTN","LR7OB3",76,0) . ;The lines below are not called because of the quit after the loop at SNEAK+3 "RTN","LR7OB3",77,0) . ;(not deleting them in case the lines are needed in the future.) "RTN","LR7OB3",78,0) . ; "RTN","LR7OB3",79,0) . S Z=$G(^TMP("LRX",$J,69,IFN)) "RTN","LR7OB3",80,0) . S (Y9,Y10,Y11)="" I $P($G(^LAB(60,+Z,64)),"^") S Y9=$P(^(64),"^"),Y10=$P(^LAM(Y9,0),"^"),Y9=$P(^(0),"^",2),Y11="99NLT" "RTN","LR7OB3",81,0) . S X1=$$UVID^LR7OU0($P(Z,"^"),$P(^TMP("LRX",$J,69),"^",10),Y9,Y11,Y10,.MSG,$G(SS)) "RTN","LR7OB3",82,0) . S X2="" ;Obs Start date "RTN","LR7OB3",83,0) . S X3=$$ACTCODE^LR7OU0($P(^TMP("LRX",$J,69),"^",4)) ;Specimen Action Code "RTN","LR7OB3",84,0) . S X4="" ;Specimen Received D/T "RTN","LR7OB3",85,0) . S X5=$$SAMP^LR7OU0($P(^TMP("LRX",$J,69),"^",3),$P(^TMP("LRX",$J,69),"^",10)) ;Specimen Source "RTN","LR7OB3",86,0) . S X6="" ;Filler Fld 1 (Accession) "RTN","LR7OB3",87,0) . S X7="" ;Results rpt/Sts change D/T "RTN","LR7OB3",88,0) . S X8="O" "RTN","LR7OB3",89,0) . I $G(CONTROL)="RE",$P(Z,"^",8) S X8=$S($G(CORRECT):"C",1:"F"),$P(@MSG@(ORCMSG),"|",6)="CM" ;Status "RTN","LR7OB3",90,0) . S X10=$P(^TMP("LRX",$J,69),"^",7),$P(@MSG@(3),"|",4)=X10 ;Routing Location "RTN","LR7OB3",91,0) . S X9="^^^^^"_$$URG^LR7OU0($P($G(^TMP("LRX",$J,69,IFN)),"^",2)) "RTN","LR7OB3",92,0) . I $O(LINK(0)) S CTR=CTR+1 D NTE^LR7OU01(2,"L","LINK(",CTR) K LINK "RTN","LR7OB3",93,0) . I $O(^TMP("LRX",$J,69,IFN,"NC",0)) S CTR=CTR+1 D NTE^LR7OU01("","L","^TMP(""LRX"",$J,69,"_IFN_",""NC"",",CTR) "RTN","LR7OB3",94,0) . I CONTROL'="SN" S CTR=CTR+1 D NTE^LR7OU01("","P","^TMP(""LRX"",$J,69,"_IFN_",""N"",",CTR) "RTN","LR7OB3",95,0) . I CONTROL'="SN" S CTR=CTR+1 D NTE^LR7OU01("","P","^TMP(""LRX"",$J,69,""N"",",CTR) "RTN","LR7OB3",96,0) . S CTR=CTR+1,COBR=COBR+1,OBRMSG=CTR D OBR^LR7OU01(CTR) "RTN","LR7OB3",97,0) . S CTR=CTR+1 D SDG1^LRBEBA2(IFN,.CTR,.MSG) "RTN","LR7OB3",98,0) . I CONTROL="SN" S CTR=CTR+1 D NTE^LR7OU01("","P","^TMP(""LRX"",$J,69,""N"",",CTR) "RTN","LR7OB3",99,0) . I CONTROL="SN" S CTR=CTR+1 D NTE^LR7OU01("","P","^TMP(""LRX"",$J,69,"_IFN_",""N"",",CTR) "RTN","LR7OB3",100,0) OUT ;Exit here "RTN","LR7OB3",101,0) K ^TMP("LRX",$J) "RTN","LR7OB3",102,0) Q "RTN","LR7OB3",103,0) AX8 ;Modify order status based on result status "RTN","LR7OB3",104,0) ;LR*5.2*512 added three lines below for panels "RTN","LR7OB3",105,0) ;Routine LRVER3A sets ^TMP("LR",$J,"PANEL",order number)=status (final or active) "RTN","LR7OB3",106,0) I $G(LROR100)]"",$D(^TMP("LR",$J,"PANEL",LROR100)) D Q "RTN","LR7OB3",107,0) . Q:$P($P(@MSG@(ORCMSG),"|",3),"^")'=LROR100 "RTN","LR7OB3",108,0) . S $P(@MSG@(ORCMSG),"|",6)=$S($G(^TMP("LR",$J,"PANEL",LROR100)):"CM",1:"SC") "RTN","LR7OB3",109,0) I X8="F"!(X8="C")!($G(LRSTATI)=2) S $P(@MSG@(ORCMSG),"|",6)="CM" Q ;Order Status "RTN","LR7OB3",110,0) I X8="I" S $P(@MSG@(ORCMSG),"|",6)="SC" "RTN","LR7OB3",111,0) Q "RTN","LRVER1") 0^1^B54953290^B51164514 "RTN","LRVER1",1,0) LRVER1 ;DALOI/STAFF - LAB ROUTINE DATA VERIFICATION;Sep 27, 2018@10:00:00 "RTN","LRVER1",2,0) ;;5.2;LAB SERVICE;**42,153,201,215,239,240,263,232,286,291,350,468,484,461,512**;Sep 27, 1994;Build 7 "RTN","LRVER1",3,0) ; "RTN","LRVER1",4,0) ;5.2;LAB SERVICE; CHANGE FOR PATCH LR*5.2*468; Feb 10 2016 "RTN","LRVER1",5,0) ; "RTN","LRVER1",6,0) VER ; from LRGVP "RTN","LRVER1",7,0) N LRBEY "RTN","LRVER1",8,0) S LRLLOC=0,LRCW=8,LROUTINE=$P(^LAB(69.9,1,3),U,2) I $D(^LRO(69,LRODT,1,LRSN,0)) S LRLLOC=$P(^(0),U,7) S:'$L(LRLLOC) LRLLOC=0 W !,$P(^LRO(69,LRODT,1,LRSN,1),U,6) "RTN","LRVER1",9,0) S LRCDT=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,3)):$P(^(3),U,1,2),1:$P(^(0),U,3)_U),LREAL=$P(LRCDT,U,2) "RTN","LRVER1",10,0) S LRCDT=+LRCDT,LRSAMP=$S($D(^LRO(69,LRODT,1,LRSN,0)):$P(^(0),U,3),1:"") "RTN","LRVER1",11,0) S LRIDT=$S($P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5):$P(^(3),U,5),1:"") "RTN","LRVER1",12,0) S:'LRIDT LRIDT=9999999-LRCDT "RTN","LRVER1",13,0) ; "RTN","LRVER1",14,0) ; Setup LRUID when called from LRGVP (group data review) "RTN","LRVER1",15,0) I $G(LRUID)="" N LRUID S LRUID=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^") "RTN","LRVER1",16,0) ; "RTN","LRVER1",17,0) D EXP "RTN","LRVER1",18,0) LD S LRSS="CH" ;ONLY WORKS FOR 'CH' "RTN","LRVER1",19,0) S LRMETH=LRSS IF $D(^LR(LRDFN,LRSS,LRIDT,0)) S LRMETH=$P($P(^(0),U,8),";",1) "RTN","LRVER1",20,0) W:$D(^LAB(62,+LRSAMP,0)) !,"Sample: ",$P(^(0),U) "RTN","LRVER1",21,0) K ^TMP("LR",$J,"TMP"),LRORD,LRM "RTN","LRVER1",22,0) D ^LRVER2 "RTN","LRVER1",23,0) K LRDL "RTN","LRVER1",24,0) Q "RTN","LRVER1",25,0) ; "RTN","LRVER1",26,0) ; "RTN","LRVER1",27,0) EXP ; Get the list of tests for this ACC. from LRGVG1 "RTN","LRVER1",28,0) ; Do not process tests which have been "NP" (not performed) "RTN","LRVER1",29,0) ; or merged to another accession "RTN","LRVER1",30,0) N I,N,IX,LRNLT,T1,X "RTN","LRVER1",31,0) K LRTEST,LRNAME,LRSM60 "RTN","LRVER1",32,0) S LRALERT=LROUTINE,N=0,I=0,IX=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)) "RTN","LRVER1",33,0) F S I=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I)) Q:I<.5 D "RTN","LRVER1",34,0) . S X=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I,0)) "RTN","LRVER1",35,0) . I 'X Q "RTN","LRVER1",36,0) . I $P(X,"^",6)="*Not Performed"!($P(X,"^",6)="*Merged") Q "RTN","LRVER1",37,0) . ;LR*5.2*512: modified line below to always set the panel as the parent test "RTN","LRVER1",38,0) . ;line was formerly: "RTN","LRVER1",39,0) . ; . S N=N+1,LRTEST(N)=I,LRNLT=$S($P(X,"^",2)>50:$P(X,U,9),1:$P(X,"^") "RTN","LRVER1",40,0) . ;The line above may have been coded based on the urgency field in LR*5.2*291 "RTN","LRVER1",41,0) . ;which was released in 2006 but the functionality regarding bundling/unbundling "RTN","LRVER1",42,0) . ;was not implemented. "RTN","LRVER1",43,0) . S N=N+1,LRTEST(N)=I,LRNLT=$P(X,U,9) "RTN","LRVER1",44,0) . I $P(X,"^",9),$P(X,"^")'=$P(X,"^",9),'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,$P(X,"^",9))) S LRNLT=$P(X,"^",9) "RTN","LRVER1",45,0) . S LRTEST(N,"P")=LRNLT_U_$$NLT(LRNLT) "RTN","LRVER1",46,0) . S LRAL=$P(X,U,2)#50 "RTN","LRVER1",47,0) . I LRAL S LRALERT=$S(LRAL0) S (LRMLTF,BL,C)="" D I BL'="" D LNCSET Q BL "RTN","LRVER1",142,0) . S LRSPECN=$S($D(^LAB(61,LRSPEC,0))#2:$$GET1^DIQ(61,LRSPEC_",",.01),1:"Unknown") "RTN","LRVER1",143,0) . S LRMLTF=$$GET1^DIQ(60.01,LRSPEC_","_LRLTST,30,"I") I LRMLTF="" Q ; does not have a vuid associated "RTN","LRVER1",144,0) . S BL=$$GET1^DIQ(66.3,LRMLTF_",",.04,"I") "RTN","LRVER1",145,0) . ; fix to strip off the check digit per agreement 20160920 "RTN","LRVER1",146,0) . I BL'="" S BL=$P(BL,"-",1) "RTN","LRVER1",147,0) K LRMLTF,BL,C "RTN","LRVER1",148,0) ; END OF CHANGE FOR LR*5.2*468 "RTN","LRVER1",149,0) ; START OF CHANGE FOR LR*5.2*484 "RTN","LRVER1",150,0) G LNCO "RTN","LRVER1",151,0) ; new entry point for mapping routine LRLNCV to skip checking of MLTF "RTN","LRVER1",152,0) LNCM(LRNLT,LRCDEF,LRSPEC,LRLTST) ; entry for LRLNCV "RTN","LRVER1",153,0) LNCO ; skip around point for LNC "RTN","LRVER1",154,0) ; END OF CHANGE FOR LR*5.2*484 "RTN","LRVER1",155,0) N X,N,Y,LRSPECN,VAL,ERR,TA S X="" "RTN","LRVER1",156,0) Q:'LRNLT X "RTN","LRVER1",157,0) K LRMSGM "RTN","LRVER1",158,0) S:$G(LRCDEF)="" LRCDEF="0000" "RTN","LRVER1",159,0) I $P(LRCDEF,".",2) S LRCDEF=$P(LRCDEF,".",2) "RTN","LRVER1",160,0) S LRCDEF=$S($P(LRNLT,".",2):$P(LRNLT,".",2),1:LRCDEF) "RTN","LRVER1",161,0) I $L(LRCDEF)'=4 S LRCDEF=LRCDEF_$E("0000",$L(LRCDEF),($L(LRCDEF-4))) "RTN","LRVER1",162,0) S LRCDEF=LRCDEF_" " "RTN","LRVER1",163,0) S LRSPEC=+LRSPEC "RTN","LRVER1",164,0) ;Get time aspect from 61 "RTN","LRVER1",165,0) S TA=$$GET1^DIQ(61,LRSPEC_",",.0961,"I") "RTN","LRVER1",166,0) S LRSPECN=$S($D(^LAB(61,LRSPEC,0))#2:$$GET1^DIQ(61,LRSPEC_",",.01),1:"Unknown") "RTN","LRVER1",167,0) S LRNLT=$P(LRNLT,".")_"." "RTN","LRVER1",168,0) ;Check for WKLD CODE_LOAD/WORK LIST method suffix "RTN","LRVER1",169,0) S VAL(1)=LRNLT_LRCDEF "RTN","LRVER1",170,0) S N=$$FIND1^DIC(64,"","X",.VAL,"C","","ERR") "RTN","LRVER1",171,0) ;Looking for specimen specific LOINC "RTN","LRVER1",172,0) I N,LRSPEC D I X D MSG(1) Q X "RTN","LRVER1",173,0) . I TA S X=$$GET1^DIQ(64.02,TA_","_LRSPEC_","_N_",",4,"I") Q:X "RTN","LRVER1",174,0) . S TA=$O(^LAM(N,5,LRSPEC,1,0)) ; get time aspect "RTN","LRVER1",175,0) . I TA S X=$$GET1^DIQ(64.02,TA_","_LRSPEC_","_N_",",4,"I") Q:X "RTN","LRVER1",176,0) ;Looking LOINC default "RTN","LRVER1",177,0) I N S X=$$LDEF(N) I X D MSG(2) Q X "RTN","LRVER1",178,0) I LRCDEF="0000 " Q "" "RTN","LRVER1",179,0) ;Looking for WKLD CODE_GENERIC suffix "RTN","LRVER1",180,0) K VAL "RTN","LRVER1",181,0) S VAL(1)=LRNLT_"0000 " "RTN","LRVER1",182,0) S N=$$FIND1^DIC(64,"","X",.VAL,"C","","ERR") "RTN","LRVER1",183,0) I 'N Q "" "RTN","LRVER1",184,0) ;Looking for WKLD CODE_GENERIC specimen specific LOINC "RTN","LRVER1",185,0) I LRSPEC D I X D MSG(3) Q X "RTN","LRVER1",186,0) . I TA S X=$$GET1^DIQ(64.02,TA_","_LRSPEC_","_N_",",4,"I") Q:X "RTN","LRVER1",187,0) . S TA=$O(^LAM(N,5,LRSPEC,1,0)) ; get time aspect "RTN","LRVER1",188,0) . I TA S X=$$GET1^DIQ(64.02,TA_","_LRSPEC_","_N_",",4,"I") Q:X "RTN","LRVER1",189,0) ;Looking for WKLD CODE_GENERIC default LOINC "RTN","LRVER1",190,0) I 'X,N S X=$$LDEF(N) I X D MSG(4) "RTN","LRVER1",191,0) I 'X S X="" "RTN","LRVER1",192,0) Q X "RTN","LRVER1",193,0) ; "RTN","LRVER1",194,0) ; START OF CHANGE FOR LR*5.2*484 "RTN","LRVER1",195,0) LNCSET ; set up string for MLTF msg "RTN","LRVER1",196,0) ; "RTN","LRVER1",197,0) S:$G(LRCDEF)="" LRCDEF="0000" "RTN","LRVER1",198,0) I $P(LRCDEF,".",2) S LRCDEF=$P(LRCDEF,".",2) "RTN","LRVER1",199,0) S LRCDEF=$S($P(LRNLT,".",2):$P(LRNLT,".",2),1:LRCDEF) "RTN","LRVER1",200,0) I $L(LRCDEF)'=4 S LRCDEF=LRCDEF_$E("0000",$L(LRCDEF),($L(LRCDEF-4))) "RTN","LRVER1",201,0) S LRCDEF=LRCDEF_" " "RTN","LRVER1",202,0) ;Get time aspect from 61 "RTN","LRVER1",203,0) S TA=$$GET1^DIQ(61,LRSPEC_",",.0961,"I") "RTN","LRVER1",204,0) S LRSPECN=$S($D(^LAB(61,LRSPEC,0))#2:$$GET1^DIQ(61,LRSPEC_",",.01),1:"Unknown") "RTN","LRVER1",205,0) S LRNLT=$P(LRNLT,".")_"." "RTN","LRVER1",206,0) I $G(TA) S TANAME=$$GET1^DIQ(64.061,TA_",",.01,"E") ;TA Name "RTN","LRVER1",207,0) S LRMSGM="1-"_LRNLT_$E(LRCDEF,1,4)_" - "_LRSPECN "RTN","LRVER1",208,0) I $G(TA) S LRMSGM=LRMSGM_" Time Aspect "_TANAME "RTN","LRVER1",209,0) Q "RTN","LRVER1",210,0) ; "RTN","LRVER1",211,0) ; END OF CHANGE FOR LR*5.2*484 "RTN","LRVER1",212,0) LDEF(Y) ;Find the default LOINC code for WKLD CODE "RTN","LRVER1",213,0) I 'Y Q "" "RTN","LRVER1",214,0) S X=$$GET1^DIQ(64,Y_",",25,"I") "RTN","LRVER1",215,0) I 'X S X="" "RTN","LRVER1",216,0) Q X "RTN","LRVER1",217,0) ; "RTN","LRVER1",218,0) ; "RTN","LRVER1",219,0) TMPSB(LRSB) ; Get LOINC code from ^TMP("LR",$J,"TMP",LRSB,"P") "RTN","LRVER1",220,0) S NODE=$G(^TMP("LR",$J,"TMP",LRSB,"P")) "RTN","LRVER1",221,0) I 'NODE Q "" "RTN","LRVER1",222,0) ; START CHANGE FOR LR*5.2*468 "RTN","LRVER1",223,0) ; S $P(NODE,"!",3)=$$LNC($P(NODE,"!",2),$G(LRCDEF),$G(LRSPEC)) "RTN","LRVER1",224,0) S $P(NODE,"!",3)=$$LNC($P(NODE,"!",2),$G(LRCDEF),$G(LRSPEC),$G(LRTS)) "RTN","LRVER1",225,0) ; END CHANGE FOR LR*5.2*468 "RTN","LRVER1",226,0) S $P(NODE,"!",4)=$G(LRCDEF) "RTN","LRVER1",227,0) Q $P(NODE,U,2) "RTN","LRVER1",228,0) ; "RTN","LRVER1",229,0) ; "RTN","LRVER1",230,0) MSG(VAL) ;Set output message "RTN","LRVER1",231,0) Q:'$G(LRMSG) "RTN","LRVER1",232,0) S LRMSGM="0-No LOINC Code Defined for "_LRNLT_LRCDEF "RTN","LRVER1",233,0) N TANAME "RTN","LRVER1",234,0) I $G(TA) S TANAME=$$GET1^DIQ(64.061,TA_",",.01,"E") ;TA Name "RTN","LRVER1",235,0) I VAL=1 S LRMSGM="1-"_LRNLT_$E(LRCDEF,1,4)_" - "_LRSPECN "RTN","LRVER1",236,0) I VAL=2 S LRMSGM="2-"_LRNLT_$E(LRCDEF,1,4)_" - Default LOINC" "RTN","LRVER1",237,0) I VAL=3 S LRMSGM="3-"_LRNLT_"0000 - "_LRSPECN "RTN","LRVER1",238,0) I VAL=4 S LRMSGM="4-"_LRNLT_"0000 - Default LOINC" "RTN","LRVER1",239,0) I $G(TA) S LRMSGM=LRMSGM_" Time Aspect "_TANAME "RTN","LRVER1",240,0) W:$G(LRDBUG) !,LRMSGM,! "RTN","LRVER1",241,0) Q "RTN","LRVER3A") 0^2^B124646001^B25488291 "RTN","LRVER3A",1,0) LRVER3A ;DALOI/FHS - DATA VERIFICATION;Sep 27, 2018@10:00:00 "RTN","LRVER3A",2,0) ;;5.2;LAB SERVICE;**1,5,42,100,121,153,190,221,254,263,266,274,295,373,350,512**;Sep 27, 1994;Build 7 "RTN","LRVER3A",3,0) ; "RTN","LRVER3A",4,0) ; Also contains LRORFLG to restrict multiple OERR alerts (VER+2) "RTN","LRVER3A",5,0) ; Reference to ^DIC(42 supported by IA #10039 "RTN","LRVER3A",6,0) ; "RTN","LRVER3A",7,0) VER ; Call with L ^LR(LRDFN,LRSS,LRIDT) from LRGV2, LRGVG1, LRSTUF1, LRSTUF2, LRVR3 "RTN","LRVER3A",8,0) Q:'$O(LRSB(0)) "RTN","LRVER3A",9,0) K ^TMP("LR",$J,"PANEL") "RTN","LRVER3A",10,0) ; "RTN","LRVER3A",11,0) N LRVCHK,LRORTST,LRORFLG,LRT "RTN","LRVER3A",12,0) S LRORU3=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),(LRAOD,LRACD)=$P(^(0),U,3) "RTN","LRVER3A",13,0) S LRACD=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,9)):^(9),1:LRACD) "RTN","LRVER3A",14,0) S:'($D(^LRO(68,LRAA,1,LRACD,1,LRAN,0))#2) LRACD=LRAD "RTN","LRVER3A",15,0) S LRAOD=$S($D(^LRO(68,LRAA,1,LRAOD,1,LRAN,0))#2:LRAOD,1:LRAD) "RTN","LRVER3A",16,0) I '$G(LRFIX) S LRNOW=$$NOW^XLFDT,$P(^LR(LRDFN,LRSS,LRIDT,0),U,3,4)=LRNOW_U_$S($G(LRDUZ):LRDUZ,1:DUZ) "RTN","LRVER3A",17,0) K A2 "RTN","LRVER3A",18,0) I '$D(PNM) S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX S:PNM="" PNM="NONAME" "RTN","LRVER3A",19,0) N LRT "RTN","LRVER3A",20,0) S LRT=0 "RTN","LRVER3A",21,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 "RTN","LRVER3A",22,0) . I $S(LRVCHK<1:1,$D(LRSB(LRVCHK))#2:1,1:0) D "RTN","LRVER3A",23,0) . . I $D(LRSB(LRVCHK)) Q:$P(LRSB(LRVCHK),U)="" "RTN","LRVER3A",24,0) . . I LRVCHK<1,$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0),U,6)'="" Q "RTN","LRVER3A",25,0) . . ; "RTN","LRVER3A",26,0) . . ;LR7OB3 will correctly evaluate the panel status due to setting of ^XTMP("LR",$J,"PANEL".. "RTN","LRVER3A",27,0) . . ;Panel statuses (i.e LRVCHK<1) will be set after all component statuses are "RTN","LRVER3A",28,0) . . ;evaluated "RTN","LRVER3A",29,0) . . I LRVCHK>1 D "RTN","LRVER3A",30,0) . . . S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0),U,4)=$S($G(LRDUZ):LRDUZ,$G(DUZ):DUZ,1:"") "RTN","LRVER3A",31,0) . . . I '$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0),U,5) S $P(^(0),U,5)=LRNOW "RTN","LRVER3A",32,0) . . . S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0),U,6)="",$P(^(0),U,8)=$G(LRCDEF) "RTN","LRVER3A",33,0) . . S LRORTST(LRT)="" "RTN","LRVER3A",34,0) . . ; "RTN","LRVER3A",35,0) . . I LRVCHK>1,LRACD'=LRAD,$D(^LRO(68,LRAA,1,LRACD,1,LRAN,4,+LRT,0)),LRVCHK>1 D "RTN","LRVER3A",36,0) . . . S $P(^LRO(68,LRAA,1,LRACD,1,LRAN,4,+LRT,0),U,4)=$S($G(LRDUZ):LRDUZ,$G(DUZ):DUZ,1:"") "RTN","LRVER3A",37,0) . . . I '$P(^LRO(68,LRAA,1,LRACD,1,LRAN,4,+LRT,0),U,5) S $P(^(0),U,5)=LRNOW "RTN","LRVER3A",38,0) . . . S $P(^LRO(68,LRAA,1,LRACD,1,LRAN,4,+LRT,0),U,6)="",$P(^(0),U,8)=$G(LRCDEF) "RTN","LRVER3A",39,0) . . I $P($G(LRPARAM),U,14),$P($G(^LRO(68,+LRAA,0)),U,16) S ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_LRT)="" "RTN","LRVER3A",40,0) . . K A2(LRT) "RTN","LRVER3A",41,0) ; "RTN","LRVER3A",42,0) S D1=1,X=0 "RTN","LRVER3A",43,0) F S X=$O(^TMP("LR",$J,"TMP",X)) Q:X<1 S LRT=+^(X) I $D(LRM(X)) D REQ "RTN","LRVER3A",44,0) 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 "RTN","LRVER3A",45,0) 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)="" "RTN","LRVER3A",46,0) ; Class I CareVue routine TASKED if CareVue ward - pwc/10-2000 "RTN","LRVER3A",47,0) D "RTN","LRVER3A",48,0) . N I,LR7DLOC D IN5^VADPT S LR7DLOC=$G(^DIC(42,+$P($G(VAIP(5)),"^"),44)) "RTN","LRVER3A",49,0) . Q:'LR7DLOC D:$D(^LAB(62.487,"C",LR7DLOC)) ;good ward location "RTN","LRVER3A",50,0) . . S ZTRTN="^LA7DLOC",ZTDESC="LAB AUTOMATION CAREVUE SUPPORTED WARDS" "RTN","LRVER3A",51,0) . . S ZTIO="",ZTDTH=$H,ZTSAVE("L*")="" D ^%ZTLOAD "RTN","LRVER3A",52,0) . . K ZTSAVE,ZTSK,ZTRTN,ZTIO,ZTDTH,ZTDESC,ZTREQ,ZTQUEUED "RTN","LRVER3A",53,0) ; "RTN","LRVER3A",54,0) 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)="" "RTN","LRVER3A",55,0) D XREF I $D(^LRO(68,LRAA,.2))'[0 X ^(.2) "RTN","LRVER3A",56,0) ; "RTN","LRVER3A",57,0) ;LR*5.2*512 added panel evaluation which builds ^TMP("LR",$J,"PANEL",order number)=status "RTN","LRVER3A",58,0) ;Routine LR7OB3 evaluates the panel status before setting "CM" or "SC" in the ORC segment. "RTN","LRVER3A",59,0) D PANEL "RTN","LRVER3A",60,0) ; "RTN","LRVER3A",61,0) N CORRECT S:$G(LRCORECT) CORRECT=1 D NEW^LR7OB1(LRODT,LRSN,"RE",,.LRORTST) "RTN","LRVER3A",62,0) L -^LR(LRDFN,LRSS,LRIDT) ; unlock "RTN","LRVER3A",63,0) ;second kill to be safe "RTN","LRVER3A",64,0) K ^TMP("LR",$J,"PANEL") "RTN","LRVER3A",65,0) Q "RTN","LRVER3A",66,0) ; "RTN","LRVER3A",67,0) ; "RTN","LRVER3A",68,0) XREF ; from COM1^LRVER4, LRTSTOUT and VER^LRVER3A "RTN","LRVER3A",69,0) I LRDPF=62.3 S ^LRO(68,LRAA,1,LRAD,1,"AD",DT,LRAN)="" Q "RTN","LRVER3A",70,0) S LRPRAC=$$PRAC^LRX($P(^LR(LRDFN,LRSS,LRIDT,0),U,10)) ;get doc name "RTN","LRVER3A",71,0) S ^LRO(68,LRAA,1,LRAD,1,"AD",DT,LRAN)="" "RTN","LRVER3A",72,0) S ^LRO(69,9999999-LRIDT\1,1,"AP",LRPRAC,$E(PNM,1,30),LRDFN)="" "RTN","LRVER3A",73,0) I $G(LRLLOC)'="" D "RTN","LRVER3A",74,0) . S ^LRO(69,9999999-LRIDT\1,1,"AL",$E(LRLLOC,1,20),$E(PNM,1,30),LRDFN)="" "RTN","LRVER3A",75,0) . S ^LRO(69,DT,1,"AN",$E(LRLLOC,1,20),LRDFN,LRIDT)="" "RTN","LRVER3A",76,0) . S ^LRO(69,DT,1,"AR",$E(LRLLOC,1,20),$E(PNM,1,30),LRDFN)="" "RTN","LRVER3A",77,0) . S ^LRO(69,"AN",$E(LRLLOC,1,20),LRDFN,LRIDT)="" "RTN","LRVER3A",78,0) I LRDPF=2 D CHSET^LRPX(LRDFN,LRIDT) "RTN","LRVER3A",79,0) Q:'$P(LRPARAM,U,3) "RTN","LRVER3A",80,0) ; "RTN","LRVER3A",81,0) TSKM ; "RTN","LRVER3A",82,0) N KK,ZTSK,ZTRTN,ZTDTH,ZTSAVE,ZTIO "RTN","LRVER3A",83,0) F KK="LRDFN","LRAA","LRAOD","LRAD","LRAN","LRIDT","LRSS","LRLLOC","LRSN","LRODT" S ZTSAVE(KK)="" "RTN","LRVER3A",84,0) S ZTRTN="DQ^LRTP",ZTIO="",ZTDTH=$H,ZTDESC="LAB INTERIM REPORTS" D ^%ZTLOAD "RTN","LRVER3A",85,0) Q "RTN","LRVER3A",86,0) ; "RTN","LRVER3A",87,0) PANEL ; "RTN","LRVER3A",88,0) N LRPNL,LRCOMP,LRPARENT,LR69TST,LRORDTST "RTN","LRVER3A",89,0) D PANEL1,PANEL2 "RTN","LRVER3A",90,0) ;find order numbers for each parent test "RTN","LRVER3A",91,0) S LRPARENT="" "RTN","LRVER3A",92,0) F S LRPARENT=$O(LRCOMP(LRPARENT)) Q:'LRPARENT D "RTN","LRVER3A",93,0) . S LR69TST=$O(^LRO(69,LRODT,1,LRSN,2,"B",LRPARENT,"")) Q:'LR69TST "RTN","LRVER3A",94,0) . ;LRORDTST = CPRS file 100 order number "RTN","LRVER3A",95,0) . S LRORDTST=$P($G(^LRO(69,LRODT,1,LRSN,2,LR69TST,0)),U,7) "RTN","LRVER3A",96,0) . Q:'LRORDTST "RTN","LRVER3A",97,0) . S ^TMP("LR",$J,"PANEL",LRORDTST)=LRCOMP(LRPARENT) "RTN","LRVER3A",98,0) Q "RTN","LRVER3A",99,0) ; "RTN","LRVER3A",100,0) PANEL1 ;gather panel components and related information "RTN","LRVER3A",101,0) ; "RTN","LRVER3A",102,0) N LRTST,LRSTR,LRPANX "RTN","LRVER3A",103,0) S LRTST=0 "RTN","LRVER3A",104,0) F S LRTST=$O(^TMP("LR",$J,"VTO",LRTST)) Q:'LRTST D "RTN","LRVER3A",105,0) . ;check to see if the test is a panel within a panel "RTN","LRVER3A",106,0) . I $O(^LAB(60,LRTST,2,0)),'$D(LRCOMP(LRTST)) S LRCOMP(LRTST)=1 "RTN","LRVER3A",107,0) . S LRPARENT=$P($G(^TMP("LR",$J,"VTO",LRTST,"P")),U) "RTN","LRVER3A",108,0) . ;not a panel, so quit "RTN","LRVER3A",109,0) . I LRPARENT']""!('$O(^LAB(60,+LRPARENT,2,0))) Q "RTN","LRVER3A",110,0) . ;initialize if first time evaluating this parent "RTN","LRVER3A",111,0) . I '$D(LRCOMP(LRPARENT)) S LRCOMP(LRPARENT)=1 "RTN","LRVER3A",112,0) F S LRTST=$O(LRCOMP(LRTST)) Q:'LRTST D "RTN","LRVER3A",113,0) . ;check whether all atomic tests have correct status, etc. "RTN","LRVER3A",114,0) . D ATOMIC "RTN","LRVER3A",115,0) . ;retrieve all atomic tests for this parent "RTN","LRVER3A",116,0) . I '$D(LRPNL(LRTST)) D LRTST(LRTST,LRTST,1) "RTN","LRVER3A",117,0) Q "RTN","LRVER3A",118,0) ; "RTN","LRVER3A",119,0) ATOMIC ; "RTN","LRVER3A",120,0) ;if component has been resulted but has been set previously "RTN","LRVER3A",121,0) ;into ^LRO(68, the LRCAP* routines won't update the complete date "RTN","LRVER3A",122,0) ;correcting the issue here so that all panel related logic is "RTN","LRVER3A",123,0) ;in one place "RTN","LRVER3A",124,0) ; "RTN","LRVER3A",125,0) N LR63 "RTN","LRVER3A",126,0) S LR63=$P($P(^LAB(60,LRTST,0),U,5),";",2) "RTN","LRVER3A",127,0) Q:'LR63 "RTN","LRVER3A",128,0) I $D(LRSB(LR63)),$P(LRSB(LR63),U)]"",$P(LRSB(LR63),U)'["pending",$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTST,0)) D "RTN","LRVER3A",129,0) . I '$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTST,0),U,4) S $P(^(0),U,4)=$S($G(LRDUZ):LRDUZ,$G(DUZ):DUZ,1:"") "RTN","LRVER3A",130,0) . I '$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTST,0),U,5) S $P(^(0),U,5)=LRNOW "RTN","LRVER3A",131,0) . ;not setting workload suffix field (#8) if disposition field (#6) is already set "RTN","LRVER3A",132,0) . ;so as to not affect workload already counted "RTN","LRVER3A",133,0) . I '$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTST,0),U,6) S $P(^(0),U,8)=$G(LRCDEF) "RTN","LRVER3A",134,0) . I $G(LRACD)]"",LRACD'=LRAD,$D(^LRO(68,LRAA,1,LRACD,1,LRAN,4,LRTST,0)) D "RTN","LRVER3A",135,0) . . I '$P(^LRO(68,LRAA,1,LRACD,1,LRAN,4,LRTST,0),U,4) S $P(^(0),U,4)=$S($G(LRDUZ):LRDUZ,$G(DUZ):DUZ,1:"") "RTN","LRVER3A",136,0) . . I '$P(^LRO(68,LRAA,1,LRACD,1,LRAN,4,LRTST,0),U,5) S $P(^(0),U,5)=LRNOW "RTN","LRVER3A",137,0) . . ;not setting workload suffix field (#8) if disposition field (#6) is already set "RTN","LRVER3A",138,0) . . ;so as to not affect workload already counted "RTN","LRVER3A",139,0) . . I '$P(^LRO(68,LRAA,1,LRACD,1,LRAN,4,LRTST,0),U,6) S $P(^(0),U,8)=$G(LRCDEF) "RTN","LRVER3A",140,0) Q "RTN","LRVER3A",141,0) ; "RTN","LRVER3A",142,0) LRTST(LRPARENT,LRSUB,LRGO) ; "RTN","LRVER3A",143,0) ;retrieve all required tests for a panel "RTN","LRVER3A",144,0) N LRA,LRTEST,LRTESTX,LRDISP,LRTX,LRPANZ,LRAAX "RTN","LRVER3A",145,0) S LRA=0 "RTN","LRVER3A",146,0) F S LRA=$O(^LAB(60,LRSUB,2,LRA)) Q:'LRA D "RTN","LRVER3A",147,0) . S LRTEST=+$G(^LAB(60,LRSUB,2,LRA,0)) Q:'LRTEST "RTN","LRVER3A",148,0) . I $O(^LAB(60,LRTEST,2,0))]"" D Q "RTN","LRVER3A",149,0) . . ;this is a panel within a panel - store for later evaluation "RTN","LRVER3A",150,0) . . S LRPANZ(LRTEST)="" "RTN","LRVER3A",151,0) . ;check to see if this test is a required test "RTN","LRVER3A",152,0) . I $P($G(^LAB(60,LRTEST,0)),U,17) D "RTN","LRVER3A",153,0) . . ;get information for each atomic test within the panel "RTN","LRVER3A",154,0) . . D LRPNL "RTN","LRVER3A",155,0) ;if LRGO is 0, panels within panels are being evaluated "RTN","LRVER3A",156,0) ;so need to store off the panels within panels within panels "RTN","LRVER3A",157,0) I 'LRGO,$D(LRPANZ) M LRPANZ1=LRPANZ "RTN","LRVER3A",158,0) ; "RTN","LRVER3A",159,0) I LRGO,$D(LRPANZ1) M LRPANZ=LRPANZ1 K LRPANZ1 "RTN","LRVER3A",160,0) ; "RTN","LRVER3A",161,0) ;break down panels within panels "RTN","LRVER3A",162,0) I $D(LRPANZ),LRGO D "RTN","LRVER3A",163,0) . ;must merge to new array because LRPANZ might be "RTN","LRVER3A",164,0) . ;re-created for panels within panels within panels... "RTN","LRVER3A",165,0) . K LRPANX "RTN","LRVER3A",166,0) . M LRPANX=LRPANZ K LRPANZ "RTN","LRVER3A",167,0) . S LRB="",LRDONE=0 "RTN","LRVER3A",168,0) . F S LRB=$O(LRPANX(LRB)) Q:'LRB D "RTN","LRVER3A",169,0) . . ;flag that this is the last entry in the array indicates "RTN","LRVER3A",170,0) . . ;that may continue looking for panel within a panel "RTN","LRVER3A",171,0) . . I $O(LRPANX(LRB))="" S LRDONE=1 "RTN","LRVER3A",172,0) . . D LRTST(LRPARENT,LRB,LRDONE) "RTN","LRVER3A",173,0) . ; "RTN","LRVER3A",174,0) . ;a second kill of LRPANX is needed for certain situations "RTN","LRVER3A",175,0) . ;when a single panel is embedded within another panel. "RTN","LRVER3A",176,0) . ;Execution occurs twice which causes no harm, but adding "RTN","LRVER3A",177,0) . ;second kill in case a situation occurs which would cause "RTN","LRVER3A",178,0) . ;an endless loop. "RTN","LRVER3A",179,0) . K LRPANX "RTN","LRVER3A",180,0) Q "RTN","LRVER3A",181,0) ; "RTN","LRVER3A",182,0) LRPNL ; "RTN","LRVER3A",183,0) N LRTX,LRSTR,LRAAX,LRADX,LRANX,LRIDTX "RTN","LRVER3A",184,0) S LRTX=$P(^LAB(60,LRTEST,0),U,5) "RTN","LRVER3A",185,0) Q:LRTX']"" "RTN","LRVER3A",186,0) ;Accession area and accession number might differ among components "RTN","LRVER3A",187,0) S LR69TST=$O(^LRO(69,LRODT,1,LRSN,2,"B",LRTEST,"")) "RTN","LRVER3A",188,0) I 'LR69TST S LR69TST=$O(^LRO(69,LRODT,1,LRSN,2,"B",LRSUB,"")) "RTN","LRVER3A",189,0) Q:'LR69TST "RTN","LRVER3A",190,0) S LRSTR=$G(^LRO(69,LRODT,1,LRSN,2,LR69TST,0)) "RTN","LRVER3A",191,0) S LRAAX=$P(LRSTR,U,4) "RTN","LRVER3A",192,0) S LRADX=$P(LRSTR,U,3) "RTN","LRVER3A",193,0) S LRANX=$P(LRSTR,U,5) "RTN","LRVER3A",194,0) S LRIDTX=$P($G(^LRO(68,+LRAAX,1,+LRADX,1,+LRANX,3)),U,5) "RTN","LRVER3A",195,0) ;LRPNL(LRPARENT,LRTEST)=File 63 dept (2nd) subscript^File 63 test (4rd) subscript^accession area "RTN","LRVER3A",196,0) ; ^accession date^accession number^File 63 inverted date/time (3rd) subscript "RTN","LRVER3A",197,0) S LRPNL(LRPARENT,LRTEST)=$P(LRTX,";")_U_$P(LRTX,";",2)_U_LRAAX_U_LRADX_U_LRANX_U_LRIDTX "RTN","LRVER3A",198,0) Q "RTN","LRVER3A",199,0) ; "RTN","LRVER3A",200,0) PANEL2 ; "RTN","LRVER3A",201,0) ;evaluate all components / atomic tests of each parent "RTN","LRVER3A",202,0) N LRPARENT,LRTX,LRTSTX,LRSTR,LR63X,LRAAX,LRADX,LRANX,LRIDTX,LRADX2 "RTN","LRVER3A",203,0) ; "RTN","LRVER3A",204,0) ;LRPNL(PARENT,TEST NUMBER)=FILE 63 DEPT (2ND) SUBSCRIPT_"^"_TEST (4TH) SUBSCRIPT IN FILE 63 "RTN","LRVER3A",205,0) ; _"^"_ACCESSION AREA IN FILE 68_"^"_ACCESSION DATE_"^"_ "RTN","LRVER3A",206,0) ; ACCESSION NUMBER"_"^"_FILE 63 INVERTED DATE/TIME (3RD) SUBSCRIPT "RTN","LRVER3A",207,0) ; "RTN","LRVER3A",208,0) S (LRPARENT,LRTSTX)="" "RTN","LRVER3A",209,0) F S LRPARENT=$O(LRPNL(LRPARENT)) Q:LRPARENT="" D "RTN","LRVER3A",210,0) . F S LRTSTX=$O(LRPNL(LRPARENT,LRTSTX)) Q:LRTSTX="" D "RTN","LRVER3A",211,0) . . ;quit if already determined that a component is still pending "RTN","LRVER3A",212,0) . . ;don't look further for a final status on the panel "RTN","LRVER3A",213,0) . . I '$G(LRCOMP(LRPARENT)) Q "RTN","LRVER3A",214,0) . . S LRSTR=LRPNL(LRPARENT,LRTSTX) "RTN","LRVER3A",215,0) . . ; "RTN","LRVER3A",216,0) . . ;LR63X = file 63 dept subscript "RTN","LRVER3A",217,0) . . ;LRTX = file 63 test subscript "RTN","LRVER3A",218,0) . . ;LRAAX = accession area "RTN","LRVER3A",219,0) . . ;LRADX = accession date "RTN","LRVER3A",220,0) . . ;LRANX = accession number "RTN","LRVER3A",221,0) . . ;LRIDTX = file 63 inverted date/time subscript "RTN","LRVER3A",222,0) . . S LR63X=$P(LRSTR,U) "RTN","LRVER3A",223,0) . . S LRTX=$P(LRSTR,U,2) "RTN","LRVER3A",224,0) . . S LRAAX=$P(LRSTR,U,3) "RTN","LRVER3A",225,0) . . S LRADX=$P(LRSTR,U,4) "RTN","LRVER3A",226,0) . . S LRANX=$P(LRSTR,U,5) "RTN","LRVER3A",227,0) . . S LRIDTX=$P(LRSTR,U,6) "RTN","LRVER3A",228,0) . . I $G(^LRO(68,+LRAAX,1,+LRADX,1,+LRANX,9)) S LRADX=^LRO(68,+LRAAX,1,+LRADX,1,+LRANX,9) "RTN","LRVER3A",229,0) . . I $P($G(^LRO(68,+LRAAX,1,+LRADX,1,+LRANX,4,LRPARENT,0)),U,5)]"" Q "RTN","LRVER3A",230,0) . . I LRIDTX>1,LR63X]"" D "RTN","LRVER3A",231,0) . . . ;check for any tests not yet verified or pending "RTN","LRVER3A",232,0) . . . ;if any tests are not verified or are pending, the panel is not yet complete "RTN","LRVER3A",233,0) . . . I '$D(^LR(LRDFN,LR63X,+LRIDTX,+LRTX)) S LRCOMP(LRPARENT)=0 "RTN","LRVER3A",234,0) . . . I $P($G(^LR(LRDFN,LR63X,+LRIDTX,+LRTX)),U)["pend" S LRCOMP(LRPARENT)=0 "RTN","LRVER3A",235,0) ;update parent level in file 68 "RTN","LRVER3A",236,0) D UPDPAR "RTN","LRVER3A",237,0) Q "RTN","LRVER3A",238,0) ; "RTN","LRVER3A",239,0) UPDPAR ; "RTN","LRVER3A",240,0) ; "RTN","LRVER3A",241,0) ;If the panel encompasses multiple accession areas, an entry may "RTN","LRVER3A",242,0) ;not be present in file 68 at the panel level. "RTN","LRVER3A",243,0) ; "RTN","LRVER3A",244,0) S LRPARENT="" "RTN","LRVER3A",245,0) F S LRPARENT=$O(LRCOMP(LRPARENT)) Q:LRPARENT="" D "RTN","LRVER3A",246,0) . I '$G(LRCOMP(LRPARENT))!('$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRPARENT,0))) Q "RTN","LRVER3A",247,0) . S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRPARENT,0),U,4)=$S($G(LRDUZ):LRDUZ,$G(DUZ):DUZ,1:"") "RTN","LRVER3A",248,0) . I '$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRPARENT,0),U,5) S $P(^(0),U,5)=LRNOW "RTN","LRVER3A",249,0) . S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRPARENT,0),U,6)="",$P(^(0),U,8)=$G(LRCDEF) "RTN","LRVER3A",250,0) . I $G(LRACD)]"",LRACD'=LRAD,$D(^LRO(68,LRAA,1,LRACD,1,LRAN,4,LRPARENT,0)) D "RTN","LRVER3A",251,0) . . S $P(^LRO(68,LRAA,1,LRACD,1,LRAN,4,LRPARENT,0),U,4)=$S($G(LRDUZ):LRDUZ,$G(DUZ):DUZ,1:"") "RTN","LRVER3A",252,0) . . I '$P(^LRO(68,LRAA,1,LRACD,1,LRAN,4,LRPARENT,0),U,5) S $P(^(0),U,5)=LRNOW "RTN","LRVER3A",253,0) . . S $P(^LRO(68,LRAA,1,LRACD,1,LRAN,4,LRPARENT,0),U,6)="",$P(^(0),U,8)=$G(LRCDEF) "RTN","LRVER3A",254,0) Q "RTN","LRVER3A",255,0) ; "RTN","LRVER3A",256,0) REQ ; "RTN","LRVER3A",257,0) Q:$P($G(LRSB(X)),U)="comment" "RTN","LRVER3A",258,0) I $D(LRSB(X)),$P(LRSB(X),U)="canc" Q "RTN","LRVER3A",259,0) I $D(LRSB(X)),$P(LRSB(X),U)'["pending" Q "RTN","LRVER3A",260,0) I $P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0)),U,6)'="" Q "RTN","LRVER3A",261,0) S:'$G(LRALERT) LRALERT=$S($G(LROUTINE):LROUTINE,1:9) "RTN","LRVER3A",262,0) S D1=0 N A,LRPPURG "RTN","LRVER3A",263,0) I $D(LRSB(X)),LRSB(X)["pending",$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0))#2 D Q "RTN","LRVER3A",264,0) . 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")) "RTN","LRVER3A",265,0) . D REQ1 "RTN","LRVER3A",266,0) ; "RTN","LRVER3A",267,0) ; If required test with no result then store 'pending' and related info (NLT/LOINC codes, user and division). "RTN","LRVER3A",268,0) I '$D(LRSB(X)),$P($G(^LR(LRDFN,"CH",LRIDT,X)),U)="" D STOREP "RTN","LRVER3A",269,0) ; "RTN","LRVER3A",270,0) I '$D(LRSB(X)),$P($G(^LR(LRDFN,"CH",LRIDT,X)),U)'="pending" Q "RTN","LRVER3A",271,0) 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) "RTN","LRVER3A",272,0) I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0))#2 D "RTN","LRVER3A",273,0) . S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",+LRT,+LRT)="" "RTN","LRVER3A",274,0) . S LRPPURG=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+$G(LRM(X,"P")),0)),U,2) "RTN","LRVER3A",275,0) . S:'LRPPURG LRPPURG=$S($G(LRALERT):+LRALERT,1:9) "RTN","LRVER3A",276,0) . S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0)=+LRT_U_LRPPURG,$P(^(0),U,9)=+$G(LRM(X,"P")) "RTN","LRVER3A",277,0) . S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),U,3)=+LRT,$P(^(0),U,4)=$P(^(0),U,4)+1 Q "RTN","LRVER3A",278,0) ; "RTN","LRVER3A",279,0) REQ1 ; "RTN","LRVER3A",280,0) Q:LRACD=LRAD "RTN","LRVER3A",281,0) 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")) "RTN","LRVER3A",282,0) K CNT,LRAMC "RTN","LRVER3A",283,0) Q "RTN","LRVER3A",284,0) ; "RTN","LRVER3A",285,0) ; "RTN","LRVER3A",286,0) STOREP ; Store pending as a result "RTN","LRVER3A",287,0) N LRX "RTN","LRVER3A",288,0) S LRX=$G(^LR(LRDFN,"CH",LRIDT,X)) "RTN","LRVER3A",289,0) S $P(LRX,"^")="pending" "RTN","LRVER3A",290,0) I $P(LRX,"^",3)="" S $P(LRX,"^",3)=$P($G(LRM(X,"P")),"^",2) "RTN","LRVER3A",291,0) S $P(LRX,"^",4)=$S($G(LRDUZ):LRDUZ,1:$G(DUZ)) "RTN","LRVER3A",292,0) S $P(LRX,"^",9)=$S($G(DUZ(2)):DUZ(2),1:"") "RTN","LRVER3A",293,0) S ^LR(LRDFN,"CH",LRIDT,X)=LRX "RTN","LRVER3A",294,0) Q "RTN","LRVR1") 0^4^B62383256^B56559612 "RTN","LRVR1",1,0) LRVR1 ;DALOI/CJS/JAH - LAB ROUTINE DATA VERIFICATION;Sep 27, 2018@10:00:00 "RTN","LRVR1",2,0) ;;5.2;LAB SERVICE;**42,153,221,286,291,350,424,440,512**;Sep 27, 1994;Build 7 "RTN","LRVR1",3,0) ; "RTN","LRVR1",4,0) N LRBETST,LRBEY,LRI,LRN,LRPRGSQ "RTN","LRVR1",5,0) S (LRI,LRN)=0 "RTN","LRVR1",6,0) F S LRI=$O(^LAH(LRLL,1,"C",LRAN,LRI)) Q:LRI<1 D "RTN","LRVR1",7,0) . N LRX "RTN","LRVR1",8,0) . S LRX=$G(^LAH(LRLL,1,LRI,0)) "RTN","LRVR1",9,0) . ; Quit if different accession area. "RTN","LRVR1",10,0) . I $P(LRX,"^",3),$P(LRX,"^",3)'=LRAA Q "RTN","LRVR1",11,0) . ; Quit if different accession date and not a rollover accession (same original accession date). "RTN","LRVR1",12,0) . I $P(LRX,"^",4),$P(LRX,"^",4)'=LRAD,$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",3)'=$P($G(^LRO(68,LRAA,1,$P(LRX,"^",4),1,LRAN,0)),"^",3) Q "RTN","LRVR1",13,0) . I LRN W ! "RTN","LRVR1",14,0) . S LRN=LRN+1,LRSQ=LRI,LRPRGSQ(LRI)="" "RTN","LRVR1",15,0) . W !,?2,"Seq #: ",LRI,?13," Accession: ",$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),"^") "RTN","LRVR1",16,0) . I $P(LRX,"^",10) W ?40," Results received: ",$$FMTE^XLFDT($P(LRX,"^",10),"1M") "RTN","LRVR1",17,0) . W !,?20,"UID: ",$P($G(^LAH(LRLL,1,LRI,.3),"UNKNOWN"),"^") "RTN","LRVR1",18,0) . I $P(LRX,"^",11) W ?44," Last updated: ",$$FMTE^XLFDT($P(LRX,"^",11),"1M") "RTN","LRVR1",19,0) ; "RTN","LRVR1",20,0) ; If multiple sets of results then query user if they want to display a specific sequence "RTN","LRVR1",21,0) I LRN>1 D "RTN","LRVR1",22,0) . N DIR,DIROUT,DIRUT,DTOUT,DUOUT,I,X,Y "RTN","LRVR1",23,0) . S DIR(0)="SO^0:Skip Display" "RTN","LRVR1",24,0) . S I=0 F S I=$O(LRPRGSQ(I)) Q:'I S DIR(0)=DIR(0)_";"_I_":Seq # "_I "RTN","LRVR1",25,0) . S DIR("A")="Display results associated with sequence #",DIR("B")="Skip Display" "RTN","LRVR1",26,0) . D ^DIR "RTN","LRVR1",27,0) . I Y<1 W ! Q "RTN","LRVR1",28,0) . D SEQDISP(LRLL,Y) "RTN","LRVR1",29,0) ; "RTN","LRVR1",30,0) G VER:LRN=1,T3:LRN>1 "RTN","LRVR1",31,0) ; "RTN","LRVR1",32,0) ; If attempting to verify reference lab results and no entry in LAH "RTN","LRVR1",33,0) ; associated with this accession then quit - do not allow manual entry "RTN","LRVR1",34,0) ; of ref lab results via this option. Will not store units/normals. "RTN","LRVR1",35,0) I $G(LRDUZ(2)),DUZ(2)'=LRDUZ(2) W !,"No data there" Q "RTN","LRVR1",36,0) ; "RTN","LRVR1",37,0) T1 R !,"What tray: ",X:DTIME Q:X["^"!'$T I X["?"!(X'?.N) W !,"Enter a number" G T1 "RTN","LRVR1",38,0) I X'="" S LRTRAY=X G T2 "RTN","LRVR1",39,0) I $D(^LRO(68.2,"AS",LRLL)) W !,"Can't MANUALLY add to a SEQUENCE instrument data file." G QUIT "RTN","LRVR1",40,0) W !,"Enter manually" S %=1 D YN^DICN G QUIT:%<1,T1:%=2 S LRSQ=-1 G VER "RTN","LRVR1",41,0) G VER "RTN","LRVR1",42,0) ; "RTN","LRVR1",43,0) T2 R !,"What cup: ",X:DTIME Q:X["^"!'$T I X["?"!(X'?.N) W !,"Enter a number" G T2 "RTN","LRVR1",44,0) Q:X="" "RTN","LRVR1",45,0) S LRTRCP=LRTRAY_";"_X I $L(LRTRCP)>200 S LRN=0 G T3 ;*424 - Do not allow string over 200 "RTN","LRVR1",46,0) K LRPRGSQ "RTN","LRVR1",47,0) S LRN=0 "RTN","LRVR1",48,0) F LRI=0:0 S LRI=$O(^LAH(LRLL,1,"B",LRTRCP,LRI)) Q:LRI<1 S LRN=LRN+1,LRSQ=LRI,LRPRGSQ(LRI)="" W !,?5,LRI "RTN","LRVR1",49,0) ; "RTN","LRVR1",50,0) T3 I LRN=0 W !,"No data for that tray & cup" Q "RTN","LRVR1",51,0) I LRN>1 R !,"Choose sequence number: ",X:DTIME Q:'$T I X["?"!(X'?.N) W !,"Enter a number" G T3 "RTN","LRVR1",52,0) I X["^"!(X="") K LRPRGSQ Q "RTN","LRVR1",53,0) S:LRN'=1 LRSQ=X "RTN","LRVR1",54,0) I '$D(^LAH(LRLL,1,LRSQ,0)) W !,"No data there" G T3 "RTN","LRVR1",55,0) ; "RTN","LRVR1",56,0) VER ; from LRFLAG, LRGP, LRVRW "RTN","LRVR1",57,0) N LRROOT "RTN","LRVR1",58,0) K LRTEST,LRNM,^TMP("LR",$J,"TMP") "RTN","LRVR1",59,0) S LRUID=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^") "RTN","LRVR1",60,0) ; "RTN","LRVR1",61,0) ; Determine if there are amended results to process via "EM" "RTN","LRVR1",62,0) S LRROOT=$Q(^LAH("LA7 AMENDED RESULTS",LRUID,1,LRLL)) "RTN","LRVR1",63,0) I LRROOT'="",$QS(LRROOT,1)="LA7 AMENDED RESULTS",$QS(LRROOT,2)=LRUID,$QS(LRROOT,4)=LRLL D Q "RTN","LRVR1",64,0) . W !!,"Amended results exist for this accession. Please process these" "RTN","LRVR1",65,0) . W !,"first using option Enter/verify/modify data (manual) [LRENTER]" "RTN","LRVR1",66,0) ; "RTN","LRVR1",67,0) D TEST "RTN","LRVR1",68,0) I $O(^TMP("LR",$J,"TMP",0))="" W !,"No tests in editing profile" Q "RTN","LRVR1",69,0) S X=DUZ D DUZ^LRX "RTN","LRVR1",70,0) G V2:LRSQ>0 "RTN","LRVR1",71,0) ; "RTN","LRVR1",72,0) L +^LAH(LRLL):DILOCKTM "RTN","LRVR1",73,0) I '$T Q "RTN","LRVR1",74,0) ; "RTN","LRVR1",75,0) S (^LAH(LRLL),LRSQ)=1+$G(^LAH(LRLL)) "RTN","LRVR1",76,0) S ^LAH(LRLL,1,LRSQ,0)="^^"_LRAA_"^"_LRAD_"^"_LRAN_"^^MANUAL" "RTN","LRVR1",77,0) D UID^LAGEN(LRLL,LRSQ,LRUID) "RTN","LRVR1",78,0) D UPDT^LAGEN(LRLL,LRSQ) "RTN","LRVR1",79,0) S ^LAH(LRLL,1,"C",LRAN,LRSQ)="" "RTN","LRVR1",80,0) L -^LAH(LRLL) "RTN","LRVR1",81,0) ; "RTN","LRVR1",82,0) V2 K LRPRGSQ(LRSQ) "RTN","LRVR1",83,0) S LRLLOC=0,LROUTINE=$P(^LAB(69.9,1,3),U,2) "RTN","LRVR1",84,0) I $D(^LRO(69,LRODT,1,LRSN,0)) S LRLLOC=$P(^(0),U,7) S:'$L(LRLLOC) LRLLOC=0 W !,$P(^LRO(69,LRODT,1,LRSN,1),U,6) "RTN","LRVR1",85,0) S LRCDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U) "RTN","LRVR1",86,0) I '$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),"^",3) D "RTN","LRVR1",87,0) . N %DT,LRA1,LRA2,LRA3 "RTN","LRVR1",88,0) . S %DT("B")=$$FMTE^XLFDT(LRCDT,"1") "RTN","LRVR1",89,0) . S LRSTATUS="C",LRA1=LRAA,LRA2=LRAD,LRA3=LRAN "RTN","LRVR1",90,0) . D P15^LROE1 "RTN","LRVR1",91,0) . S LRAA=LRA1,LRAD=LRA2,LRAN=LRA3 "RTN","LRVR1",92,0) . I LRCDT<1 Q "RTN","LRVR1",93,0) . I '$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,3) S $P(^(3),U,3)=$$NOW^XLFDT "RTN","LRVR1",94,0) ; If user did not update then go to next "RTN","LRVR1",95,0) I '$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,3) Q "RTN","LRVR1",96,0) S LRCDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U) "RTN","LRVR1",97,0) I LRCDT<1 Q "RTN","LRVR1",98,0) S LREAL=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,2),LRALERT=LROUTINE "RTN","LRVR1",99,0) S I=0 "RTN","LRVR1",100,0) F S I=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I)) Q:I<.5 I $G(^(I,0)) S LRAL=$P($G(^(0)),U,2) D "RTN","LRVR1",101,0) . I $G(LRAL) S LRALERT=$S(LRAL<50&(LRAL50&(LRAL-50>>>ERROR - NO POINTER TO FILE #63 - PLEASE NOTIFY SYSTEM MANAGER^ <<<<<",! Q "RTN","LRVR1",109,0) I '$D(^LR(LRDFN,LRSS,LRIDT,0)) W !,">>>>ERROR - NO ENTRY IN FILE #63 - PLEASE NOTIFY SYSTEM MANAGER<<^ <<<",! Q "RTN","LRVR1",110,0) ; "RTN","LRVR1",111,0) S LRCW=8 "RTN","LRVR1",112,0) LD S LRSS="CH" "RTN","LRVR1",113,0) ; "RTN","LRVR1",114,0) ; If bad entry then cleanup as best as possible. "RTN","LRVR1",115,0) I '($D(^LAH(LRLL,1,LRSQ,0))#2) D Q "RTN","LRVR1",116,0) . W !!?5,"No Data for this Accession ",!! "RTN","LRVR1",117,0) . D ZAPALL^LRVR3(LRLL,LRSQ) "RTN","LRVR1",118,0) . K LRPRGSQ "RTN","LRVR1",119,0) ; "RTN","LRVR1",120,0) ; Store any new methods with existing methods on file. "RTN","LRVR1",121,0) S LRMETH=$P(^LAH(LRLL,1,LRSQ,0),U,7) S:$D(LRGVP) LRMETH=LRMETH_"(GV)" "RTN","LRVR1",122,0) I $P($G(^LR(LRDFN,LRSS,LRIDT,0)),U,8)'="" D "RTN","LRVR1",123,0) . N I,X "RTN","LRVR1",124,0) . S X=$P(^LR(LRDFN,LRSS,LRIDT,0),U,8) "RTN","LRVR1",125,0) . F I=1:1:$L(X,";") I $P(X,";",I)'="",LRMETH'[$P(X,";",I) S LRMETH=LRMETH_";"_$P(X,";",I) "RTN","LRVR1",126,0) I LRMETH'="" S $P(^LR(LRDFN,LRSS,LRIDT,0),U,8)=LRMETH "RTN","LRVR1",127,0) ; "RTN","LRVR1",128,0) S LRTM60=$$LRTM60^LRVR(LRCDT) "RTN","LRVR1",129,0) ; "RTN","LRVR1",130,0) W:$D(^LAB(62,+LRSAMP,0)) !,"Sample: ",$P(^(0),U) "RTN","LRVR1",131,0) ; "RTN","LRVR1",132,0) D ^LRVR2 "RTN","LRVR1",133,0) K LRDL,LRPRGSQ "RTN","LRVR1",134,0) Q ; leave LRVR1, back to LRVR "RTN","LRVR1",135,0) ; "RTN","LRVR1",136,0) ; "RTN","LRVR1",137,0) TEST ; from LRGV1 "RTN","LRVR1",138,0) N LRI,LRX "RTN","LRVR1",139,0) S LRI=0 "RTN","LRVR1",140,0) F S LRI=$O(^TMP("LR",$J,"VTO",LRI)) Q:LRI<1 K ^(LRI,"P") "RTN","LRVR1",141,0) S (LRI,LRNT)=0 "RTN","LRVR1",142,0) F S LRI=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI)) Q:LRI<.5 I $D(^(LRI,0)),'$L($P(^(0),U,6)) S X=^(0) I $D(^TMP("LR",$J,"VTO",+X)) D "RTN","LRVR1",143,0) . ;LR*5.2*512: modified line below to always set the panel as the parent test "RTN","LRVR1",144,0) . ;line was formerly: "RTN","LRVR1",145,0) . ; . S LRNT=LRNT+1,LRTEST(LRNT)=+X,LRX=$S($P(X,"^",2)>50:$P(X,"^",9),1:$P(X,"^")) "RTN","LRVR1",146,0) . ;The line above may have been coded based on the urgency field in LR*5.2*291 "RTN","LRVR1",147,0) . ;which was released in 2006 but the functionality regarding bundling/unbundling "RTN","LRVR1",148,0) . ;was not implemented. "RTN","LRVR1",149,0) . S LRNT=LRNT+1,LRTEST(LRNT)=+X,LRX=$P(X,"^",9) "RTN","LRVR1",150,0) . I $P(X,"^",9),$P(X,"^")'=$P(X,"^",9),'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,$P(X,"^",9))) S LRX=$P(X,"^",9) "RTN","LRVR1",151,0) . S LRTEST(LRNT,"P")=LRX_U_$$NLT^LRVER1(LRX)_"!" "RTN","LRVR1",152,0) . S ^TMP("LR",$J,"VTO",+X,"P")=$P(LRTEST(LRNT,"P"),"!") "RTN","LRVR1",153,0) ; "RTN","LRVR1",154,0) TEST1 ; from LRFLAG "RTN","LRVR1",155,0) ; "RTN","LRVR1",156,0) N LRI "RTN","LRVR1",157,0) F LRI=1:1:LRNT S:$D(^LAB(60,+LRTEST(LRI),0)) (LRTEST(LRI),LRBETST(LRI))=LRTEST(LRI)_U_^(0) "RTN","LRVR1",158,0) I $G(LRORDR)'="P" K ^TMP("LR",$J,"TMP") "RTN","LRVR1",159,0) S LRNX=0 "RTN","LRVR1",160,0) K LRM "RTN","LRVR1",161,0) F I=1:1 Q:'$D(LRTEST(I)) D "RTN","LRVR1",162,0) . S X=LRTEST(I),XP=$G(LRTEST(I,"P")) "RTN","LRVR1",163,0) . K LRTEST(I) "RTN","LRVR1",164,0) . D EX2 "RTN","LRVR1",165,0) K LRTEST "RTN","LRVR1",166,0) Q "RTN","LRVR1",167,0) ; "RTN","LRVR1",168,0) ; "RTN","LRVR1",169,0) EX2 ; "RTN","LRVR1",170,0) ; If dataname then process and quit "RTN","LRVR1",171,0) S LRSUB=$P(X,U,6) "RTN","LRVR1",172,0) I LRSUB'="" D Q "RTN","LRVR1",173,0) . S LRSB=$P(LRSUB,";",2) "RTN","LRVR1",174,0) . Q:'$D(LRVTS(LRSB)) "RTN","LRVR1",175,0) . I $D(^TMP("LR",$J,"TMP",LRSB)) S ^(LRSB,"P")=XP "RTN","LRVR1",176,0) . S ^TMP("LR",$J,"TMP",LRSB)=+X "RTN","LRVR1",177,0) . S XP=XP_$$RNLT^LRVER1(+X) "RTN","LRVR1",178,0) . S ^TMP("LR",$J,"TMP",LRSB,"P")=XP "RTN","LRVR1",179,0) . S:$P(X,U,18) LRM(LRSB)=+X,LRM(LRSB,"P")=XP "RTN","LRVR1",180,0) . S LRBEY(+X,LRSB)="" ; CIDC "RTN","LRVR1",181,0) ; "RTN","LRVR1",182,0) I $D(^LAB(60,+X,4)),$P(^(4),"^",2) S LRCFL=LRCFL_$P(^(4),"^",2)_U "RTN","LRVR1",183,0) ; "RTN","LRVR1",184,0) ; If panel then explode components of panel and "RTN","LRVR1",185,0) ; set parent("P" node) to file #60 test being exploded "RTN","LRVR1",186,0) S J=0 "RTN","LRVR1",187,0) F S J=$O(^LAB(60,+X,2,J)) Q:J<1 I $D(^(J,0))#2 D "RTN","LRVR1",188,0) . S LRNT=LRNT+1,Y=^LAB(60,+X,2,J,0) "RTN","LRVR1",189,0) . S LRTEST(LRNT)=+Y_U_^LAB(60,+Y,0) "RTN","LRVR1",190,0) . S LRTEST(LRNT,"P")=+XP_U_$$NLT^LRVER1(+XP)_"!" "RTN","LRVR1",191,0) Q "RTN","LRVR1",192,0) ; "RTN","LRVR1",193,0) ; "RTN","LRVR1",194,0) QUIT Q "RTN","LRVR1",195,0) ; "RTN","LRVR1",196,0) ; "RTN","LRVR1",197,0) WAIT W !,"Type ""^"" to skip " "RTN","LRVR1",198,0) WAIT1 R X:10 "RTN","LRVR1",199,0) G LRVR1:X[U,WAIT1:$O(^LAH(LRLL,1,"C",LRAN,0))<1 "RTN","LRVR1",200,0) G LRVR1 "RTN","LRVR1",201,0) ; "RTN","LRVR1",202,0) ; "RTN","LRVR1",203,0) SEQDISP(LRLL,LRISQN) ; Display test results for a LAH entry. "RTN","LRVR1",204,0) ; Call with LRLL = ien of enry in LAH "RTN","LRVR1",205,0) ; LRISQN = sequence ien of enry in LAH "RTN","LRVR1",206,0) ; "RTN","LRVR1",207,0) N LR60,LRI,LRJ,LRSB,LRX,LRY "RTN","LRVR1",208,0) ; "RTN","LRVR1",209,0) W !!,"Results for Sequence #"_LRISQN "RTN","LRVR1",210,0) ; "RTN","LRVR1",211,0) I $O(^LAH(LRLL,1,LRISQN,1)) D "RTN","LRVR1",212,0) . W !,"Test",?25,"Value",?40,"Flag",?50,"Units" "RTN","LRVR1",213,0) . W !,"----",?25,"-----",?40,"----",?50,"-----" "RTN","LRVR1",214,0) ; "RTN","LRVR1",215,0) ; Display CH subsript results. "RTN","LRVR1",216,0) S LRSB=1 "RTN","LRVR1",217,0) F S LRSB=$O(^LAH(LRLL,1,LRISQN,LRSB)) Q:LRSB<1 D "RTN","LRVR1",218,0) . S LRX=^LAH(LRLL,1,LRISQN,LRSB) "RTN","LRVR1",219,0) . S LR60=+$O(^LAB(60,"C","CH;"_LRSB_";1",0)) "RTN","LRVR1",220,0) . S LR60(0)=$G(^LAB(60,LR60,0)) "RTN","LRVR1",221,0) . W !,$E($P(LR60(0),"^"),1,24),?25," ",$P(LRX,"^"),?39," ",$P(LRX,"^",2),?49," ",$P($P(LRX,"^",5),"!",7) "RTN","LRVR1",222,0) ; "RTN","LRVR1",223,0) ; Display comments "RTN","LRVR1",224,0) I $D(^LAH(LRLL,1,LRISQN,1)) D "RTN","LRVR1",225,0) . W !,"Comments" "RTN","LRVR1",226,0) . S (LRI,LRY)=0,LRJ="" "RTN","LRVR1",227,0) . F S LRY=$O(^LAH(LRLL,1,LRISQN,1,LRY)) Q:LRY<1 D "RTN","LRVR1",228,0) . . S LRX=^LAH(LRLL,1,LRISQN,1,LRY),LRI=LRI+1 "RTN","LRVR1",229,0) . . W !,"#",LRI," ",$P(LRX,"^") "RTN","LRVR1",230,0) . . I $P(LRX,"^",2) S LRJ=LRJ_$S(LRJ'="":",",1:"")_LRJ "RTN","LRVR1",231,0) . W !,"Comments # ",LRJ," previously processed" "RTN","LRVR1",232,0) ; "RTN","LRVR1",233,0) W ! "RTN","LRVR1",234,0) ; "RTN","LRVR1",235,0) Q "VER") 8.0^22.2 "BLD",11189,6) ^422 **END** **END**