BLRPOC3 ;IHS/MSC/MKK - EHR POC Component support, part 2 ; 13-Oct-2017 14:04 ; MKK
;;5.2;IHS LABORATORY;**1041**;NOV 01, 1997;Build 23
;
Q
;
; IHS/MSC/MKK
; TEST subroutine moved to this routine due to the BLRPOC routine
; becoming too large (i.e., violated SAC guidelines).
;
TEST ; EP - Interactively TEST Point-Of-Care
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
K ^TMP("BLRDIAG",$J) ; Make sure Diagnosis is cleared.
;
W !!,"POC Test."
S ARY("CD")=$$NOW^XLFDT
;
Q:$$GETYVAL(60,.TESTY)<1
I $$CHKTST^BLRPOC(+TESTY)<1 D Q
. D BADSTUFF("Test "_$$GET1^DIQ(60,TEST6,.01)_" ["_TESTY_"] cannot be used.")
;
S ARY("ORDTST")=$G(TESTY)
;
I $$ISPANEL^BLRPOC(+TESTY) S CONTINUE=$$GETCOSMC(TESTY,.ARY)
E D
. S ARY("TST",1)=$G(TESTY)
. S CONTINUE=$$GETRESLT(+TESTY,.RESULTS,.COMMENT)
. I CONTINUE="OK" S ARY("RES",1)=RESULTS S:RESULTS="*" ARY("CMT",1)=COMMENT
Q:$G(CONTINUE)="Q"
;
S SITESPEC=$O(^LAB(60,+TESTY,1,0))
;
S ARY("CM")=$$GET1^DIQ(61,SITESPEC,.01,"I")_U_$$GET1^DIQ(61,SITESPEC,.01)
S CSI=+$$GET1^DIQ(60,+TESTY,9,"I") ; Collection Sample IEN
I CSI<1 D
. S CSI=+$O(^LAB(60,+TESTY,3,0))
. S CSI=+$G(^LAB(60,+TESTY,3,CSI,0))
S ARY("COL")=CSI_U_$$GET1^DIQ(62,CSI,.01)
;
Q:$$GETYVAL(44,.Y)<1
S ARY("LOC")=$G(Y)
;
Q:$$GETYVAL(200,.Y,"PROVIDER")<1
S ARY("PRV")=$G(Y)
;
Q:$$GETYVAL(100.02,.Y)<1
S ARY("NOO")=$G(Y)
;
Q:$$GETYVAL(62.05,.Y)<1
S ARY("URG")=$G(Y)
;
S COMMCNT=+$O(ARY("CMT","A"),-1)
I $G(ARY("CMT",COMMCNT))'["TEST^BLRPOC" D
. S ARY("CMT",COMMCNT+1)="Testing POC Code from TEST^BLRPOC entry."
;
Q:$$GETYVAL(2,.Y)<1
S DFN=+$G(Y)
;
S STR=$$CHKITOUT^BLRSGNSU(DFN,$$DT^XLFDT)
Q:STR=""
S STR1=$P(STR,U,2)
S ARY("SYMP")=STR1_U_$P(STR,U,3)_U_$P(STR,U)
;
W !!,"Before SAVE call.",!
D ARRYDUMP("ARY")
D ^XBFMK
S DIR(0)="YO"
S DIR("A")="Make ARY(""CD"")=Just a Date"
D ^DIR
I +Y D
. S ARY("CD")=$P($G(ARY("CD")),".")
. D ARRYDUMP("ARY")
;
D PRESSKEY^BLRGMENU(9)
;
W !,"DFN:",DFN," - ",$P(Y,U,2),!
;
D SAVE^BLRPOC(.RET,DFN,.ARY)
;
W !,"After SAVE Call.",!
W ?4,"RET:",RET,!!
;
S LRDFN=$$GET1^DIQ(2,DFN,63,"I")
S LRIDT=$O(^LR(LRDFN,"CH",0))
S LRAS=$$GET1^DIQ(63.04,LRIDT_","_LRDFN,.06)
;
H 1
S BLRTXLOG=$O(^BLRTXLOG("D",LRAS,0))
I BLRTXLOG D
. S X=$$GETACCCP^BLRUTIL3(LRAS,.LRAA,.LRAD,.LRAN)
. D SHOWIT
. ; S VLABIEN=$$GET1^DIQ(9009022,BLRTXLOG,105,"I")
. ; W !,?4,"Latest Accession:",$$GET1^DIQ(63.04,LRIDT_","_LRDFN,.06),!
. ; W ?10,"BLRTXLOG:",BLRTXLOG,?30,"FLAG:",$$GET1^DIQ(9009022,BLRTXLOG,2002),!
. ; W ?9,"V LAB IEN:",VLABIEN,?30,"FLAG:",$$GET1^DIQ(9000010.09,VLABIEN,.05),!
E W ?4,"Could not determine BLRTXLOG for Accession ",LRAS,!
;
K ^TMP("BLRDIAG",$J)
Q
;
GETYVAL(FNUM,YVAL,PROMPT) ; EP - MSC/MKK - Make this a function and add ability to pass a prompt string.
D ^XBFMK
S DIR(0)="PO^"_FNUM_":EMZ"
S:$L($G(PROMPT)) DIR("A")=PROMPT
D ^DIR
I +$G(DIRUT) D INVALENT Q 0
;
S YVAL=$G(Y)
Q 1
;
INVALENT ; EP - Invalid Entry Prompt
W !,?4,"No/Quit Entry. Routine Ends."
D PRESSKEY^BLRGMENU(9)
Q
;
ARRYDUMP(ARRY) ; EP - "Dump" the array
NEW STR1
;
S STR1=$Q(@ARRY@(""))
W !,?5,ARRY,!
W ?10,STR1,"=",@STR1,!
F S STR1=$Q(@STR1) Q:STR1="" D
. W ?10,STR1,"=",@STR1,!
Q
;
; --- BEGIN MSC/MKK - Allow COSMIC tests
GETCOSMC(COSMCTST,ARRAY) ; EP - Get results for ALL tests
NEW (ARRAY,COSMCTST,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
S COSMCIEN=+$G(COSMCTST)
S (CNT,BAILOUT,PANELN)=0
F S PANELN=$O(^LAB(60,COSMCIEN,2,PANELN)) Q:PANELN<1!(BAILOUT) D
. S PANELIEN=PANELN_","_COSMCIEN
. S F60IEN=$$GET1^DIQ(60.02,PANELIEN,.01,"I")
. ; I $$GETRESLT(F60IEN,.RESULTS)="Q" S BAILOUT=BAILOUT+1 Q
. I $$GETRESLT(F60IEN,.RESULTS,.COMMENT)="Q" S BAILOUT=BAILOUT+1 Q ; MSC/MKK - LR*5.2*XXXX
. ;
. S CNT=CNT+1
. S TESTSTR=F60IEN_U_$$GET1^DIQ(60,F60IEN,.01)
. S ARRAY("TST",CNT)=$G(TESTSTR)
. S ARRAY("RES",CNT)=RESULTS
. S:RESULTS="*" ARRAY("CMT",CNT)=COMMENT ; MSC/MKK - LR*5.2*XXXX
;
Q $S(BAILOUT:"Q",1:"OK")
;
GETRESLT(IEN,RESULT,COMMENT) ; EP - Get Result Value
NEW TESTNAME
;
S COMMENT=""
S TESTNAME=$$GET1^DIQ(60,IEN,.01)
;
D ^XBFMK
S DIR(0)="FO",DIR("A")=TESTNAME_"'s Result Text or Number"
D ^DIR
I +$G(DIRUT) D INVALENT Q "Q"
S RESULT=$G(Y)
;
I RESULT="*" D
. D ^XBFMK
. S DIR(0)="FO",DIR("A")="Comment for cancelled result"
. D ^DIR
. S COMMENT=$S($L($G(X)):$G(X),1:"Cancelled")
;
Q "OK"
;
BADSTUFF(STR,TAB) ; EP - BADSTUFF error message
S TAB=$S($L($G(TAB))<1:4,1:TAB)
W !!,?TAB,STR," Routine Ends."
D PRESSKEY^BLRGMENU(TAB+5)
Q
;
SHOWFLAG ; EP - Given Accession number, show V LAB FLAG
NEW BLRLRAS,BLRTXLOG,LRAA,LRAAIEN,LRAD,LRDATA,LRAN,LRAS,VLABIEN
;
W !!
D ^LRWU4
S LRAS=BLRLRAS
;
SHOWIT ; EP
S LRAAIEN=LRAN_","_LRAD_","_LRAA
S LRDFN=$$GET1^DIQ(68.02,LRAAIEN,.01,"I")
S LRIDT=$$GET1^DIQ(68.02,LRAAIEN,13.5,"I")
S LRDATA=$O(^LR(LRDFN,"CH",LRIDT,"A"),-1)
S BLRTXLOG=$O(^BLRTXLOG("D",LRAS,0))
S VLABIEN=$$GET1^DIQ(9009022,BLRTXLOG,105,"I")
;
W !,?4,"Accession:",$$GET1^DIQ(63.04,LRIDT_","_LRDFN,.06),!
W ?8, "LAB DATA RESULT:",$P($G(^LR(LRDFN,"CH",LRIDT,LRDATA)),U),?35,"FLAG:",$P($G(^(LRDATA)),U,2),!
W ?15,"BLRTXLOG:",BLRTXLOG,?35,"FLAG:",$$GET1^DIQ(9009022,BLRTXLOG,2002),!
W ?14,"V LAB IEN:",VLABIEN,?35,"FLAG:",$$GET1^DIQ(9000010.09,VLABIEN,.05),!
D PRESSKEY^BLRGMENU(4)
Q
BLRPOC3 ;IHS/MSC/MKK - EHR POC Component support, part 2 ; 13-Oct-2017 14:04 ; MKK
+1 ;;5.2;IHS LABORATORY;**1041**;NOV 01, 1997;Build 23
+2 ;
+3 QUIT
+4 ;
+5 ; IHS/MSC/MKK
+6 ; TEST subroutine moved to this routine due to the BLRPOC routine
+7 ; becoming too large (i.e., violated SAC guidelines).
+8 ;
TEST ; EP - Interactively TEST Point-Of-Care
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 ; Make sure Diagnosis is cleared.
KILL ^TMP("BLRDIAG",$JOB)
+4 ;
+5 WRITE !!,"POC Test."
+6 SET ARY("CD")=$$NOW^XLFDT
+7 ;
+8 IF $$GETYVAL(60,.TESTY)<1
QUIT
+9 IF $$CHKTST^BLRPOC(+TESTY)<1
Begin DoDot:1
+10 DO BADSTUFF("Test "_$$GET1^DIQ(60,TEST6,.01)_" ["_TESTY_"] cannot be used.")
End DoDot:1
QUIT
+11 ;
+12 SET ARY("ORDTST")=$GET(TESTY)
+13 ;
+14 IF $$ISPANEL^BLRPOC(+TESTY)
SET CONTINUE=$$GETCOSMC(TESTY,.ARY)
+15 IF '$TEST
Begin DoDot:1
+16 SET ARY("TST",1)=$GET(TESTY)
+17 SET CONTINUE=$$GETRESLT(+TESTY,.RESULTS,.COMMENT)
+18 IF CONTINUE="OK"
SET ARY("RES",1)=RESULTS
IF RESULTS="*"
SET ARY("CMT",1)=COMMENT
End DoDot:1
+19 IF $GET(CONTINUE)="Q"
QUIT
+20 ;
+21 SET SITESPEC=$ORDER(^LAB(60,+TESTY,1,0))
+22 ;
+23 SET ARY("CM")=$$GET1^DIQ(61,SITESPEC,.01,"I")_U_$$GET1^DIQ(61,SITESPEC,.01)
+24 ; Collection Sample IEN
SET CSI=+$$GET1^DIQ(60,+TESTY,9,"I")
+25 IF CSI<1
Begin DoDot:1
+26 SET CSI=+$ORDER(^LAB(60,+TESTY,3,0))
+27 SET CSI=+$GET(^LAB(60,+TESTY,3,CSI,0))
End DoDot:1
+28 SET ARY("COL")=CSI_U_$$GET1^DIQ(62,CSI,.01)
+29 ;
+30 IF $$GETYVAL(44,.Y)<1
QUIT
+31 SET ARY("LOC")=$GET(Y)
+32 ;
+33 IF $$GETYVAL(200,.Y,"PROVIDER")<1
QUIT
+34 SET ARY("PRV")=$GET(Y)
+35 ;
+36 IF $$GETYVAL(100.02,.Y)<1
QUIT
+37 SET ARY("NOO")=$GET(Y)
+38 ;
+39 IF $$GETYVAL(62.05,.Y)<1
QUIT
+40 SET ARY("URG")=$GET(Y)
+41 ;
+42 SET COMMCNT=+$ORDER(ARY("CMT","A"),-1)
+43 IF $GET(ARY("CMT",COMMCNT))'["TEST^BLRPOC"
Begin DoDot:1
+44 SET ARY("CMT",COMMCNT+1)="Testing POC Code from TEST^BLRPOC entry."
End DoDot:1
+45 ;
+46 IF $$GETYVAL(2,.Y)<1
QUIT
+47 SET DFN=+$GET(Y)
+48 ;
+49 SET STR=$$CHKITOUT^BLRSGNSU(DFN,$$DT^XLFDT)
+50 IF STR=""
QUIT
+51 SET STR1=$PIECE(STR,U,2)
+52 SET ARY("SYMP")=STR1_U_$PIECE(STR,U,3)_U_$PIECE(STR,U)
+53 ;
+54 WRITE !!,"Before SAVE call.",!
+55 DO ARRYDUMP("ARY")
+56 DO ^XBFMK
+57 SET DIR(0)="YO"
+58 SET DIR("A")="Make ARY(""CD"")=Just a Date"
+59 DO ^DIR
+60 IF +Y
Begin DoDot:1
+61 SET ARY("CD")=$PIECE($GET(ARY("CD")),".")
+62 DO ARRYDUMP("ARY")
End DoDot:1
+63 ;
+64 DO PRESSKEY^BLRGMENU(9)
+65 ;
+66 WRITE !,"DFN:",DFN," - ",$PIECE(Y,U,2),!
+67 ;
+68 DO SAVE^BLRPOC(.RET,DFN,.ARY)
+69 ;
+70 WRITE !,"After SAVE Call.",!
+71 WRITE ?4,"RET:",RET,!!
+72 ;
+73 SET LRDFN=$$GET1^DIQ(2,DFN,63,"I")
+74 SET LRIDT=$ORDER(^LR(LRDFN,"CH",0))
+75 SET LRAS=$$GET1^DIQ(63.04,LRIDT_","_LRDFN,.06)
+76 ;
+77 HANG 1
+78 SET BLRTXLOG=$ORDER(^BLRTXLOG("D",LRAS,0))
+79 IF BLRTXLOG
Begin DoDot:1
+80 SET X=$$GETACCCP^BLRUTIL3(LRAS,.LRAA,.LRAD,.LRAN)
+81 DO SHOWIT
+82 ; S VLABIEN=$$GET1^DIQ(9009022,BLRTXLOG,105,"I")
+83 ; W !,?4,"Latest Accession:",$$GET1^DIQ(63.04,LRIDT_","_LRDFN,.06),!
+84 ; W ?10,"BLRTXLOG:",BLRTXLOG,?30,"FLAG:",$$GET1^DIQ(9009022,BLRTXLOG,2002),!
+85 ; W ?9,"V LAB IEN:",VLABIEN,?30,"FLAG:",$$GET1^DIQ(9000010.09,VLABIEN,.05),!
End DoDot:1
+86 IF '$TEST
WRITE ?4,"Could not determine BLRTXLOG for Accession ",LRAS,!
+87 ;
+88 KILL ^TMP("BLRDIAG",$JOB)
+89 QUIT
+90 ;
GETYVAL(FNUM,YVAL,PROMPT) ; EP - MSC/MKK - Make this a function and add ability to pass a prompt string.
+1 DO ^XBFMK
+2 SET DIR(0)="PO^"_FNUM_":EMZ"
+3 IF $LENGTH($GET(PROMPT))
SET DIR("A")=PROMPT
+4 DO ^DIR
+5 IF +$GET(DIRUT)
DO INVALENT
QUIT 0
+6 ;
+7 SET YVAL=$GET(Y)
+8 QUIT 1
+9 ;
INVALENT ; EP - Invalid Entry Prompt
+1 WRITE !,?4,"No/Quit Entry. Routine Ends."
+2 DO PRESSKEY^BLRGMENU(9)
+3 QUIT
+4 ;
ARRYDUMP(ARRY) ; EP - "Dump" the array
+1 NEW STR1
+2 ;
+3 SET STR1=$QUERY(@ARRY@(""))
+4 WRITE !,?5,ARRY,!
+5 WRITE ?10,STR1,"=",@STR1,!
+6 FOR
SET STR1=$QUERY(@STR1)
IF STR1=""
QUIT
Begin DoDot:1
+7 WRITE ?10,STR1,"=",@STR1,!
End DoDot:1
+8 QUIT
+9 ;
+10 ; --- BEGIN MSC/MKK - Allow COSMIC tests
GETCOSMC(COSMCTST,ARRAY) ; EP - Get results for ALL tests
+1 NEW (ARRAY,COSMCTST,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 SET COSMCIEN=+$GET(COSMCTST)
+4 SET (CNT,BAILOUT,PANELN)=0
+5 FOR
SET PANELN=$ORDER(^LAB(60,COSMCIEN,2,PANELN))
IF PANELN<1!(BAILOUT)
QUIT
Begin DoDot:1
+6 SET PANELIEN=PANELN_","_COSMCIEN
+7 SET F60IEN=$$GET1^DIQ(60.02,PANELIEN,.01,"I")
+8 ; I $$GETRESLT(F60IEN,.RESULTS)="Q" S BAILOUT=BAILOUT+1 Q
+9 ; MSC/MKK - LR*5.2*XXXX
IF $$GETRESLT(F60IEN,.RESULTS,.COMMENT)="Q"
SET BAILOUT=BAILOUT+1
QUIT
+10 ;
+11 SET CNT=CNT+1
+12 SET TESTSTR=F60IEN_U_$$GET1^DIQ(60,F60IEN,.01)
+13 SET ARRAY("TST",CNT)=$GET(TESTSTR)
+14 SET ARRAY("RES",CNT)=RESULTS
+15 ; MSC/MKK - LR*5.2*XXXX
IF RESULTS="*"
SET ARRAY("CMT",CNT)=COMMENT
End DoDot:1
+16 ;
+17 QUIT $SELECT(BAILOUT:"Q",1:"OK")
+18 ;
GETRESLT(IEN,RESULT,COMMENT) ; EP - Get Result Value
+1 NEW TESTNAME
+2 ;
+3 SET COMMENT=""
+4 SET TESTNAME=$$GET1^DIQ(60,IEN,.01)
+5 ;
+6 DO ^XBFMK
+7 SET DIR(0)="FO"
SET DIR("A")=TESTNAME_"'s Result Text or Number"
+8 DO ^DIR
+9 IF +$GET(DIRUT)
DO INVALENT
QUIT "Q"
+10 SET RESULT=$GET(Y)
+11 ;
+12 IF RESULT="*"
Begin DoDot:1
+13 DO ^XBFMK
+14 SET DIR(0)="FO"
SET DIR("A")="Comment for cancelled result"
+15 DO ^DIR
+16 SET COMMENT=$SELECT($LENGTH($GET(X)):$GET(X),1:"Cancelled")
End DoDot:1
+17 ;
+18 QUIT "OK"
+19 ;
BADSTUFF(STR,TAB) ; EP - BADSTUFF error message
+1 SET TAB=$SELECT($LENGTH($GET(TAB))<1:4,1:TAB)
+2 WRITE !!,?TAB,STR," Routine Ends."
+3 DO PRESSKEY^BLRGMENU(TAB+5)
+4 QUIT
+5 ;
SHOWFLAG ; EP - Given Accession number, show V LAB FLAG
+1 NEW BLRLRAS,BLRTXLOG,LRAA,LRAAIEN,LRAD,LRDATA,LRAN,LRAS,VLABIEN
+2 ;
+3 WRITE !!
+4 DO ^LRWU4
+5 SET LRAS=BLRLRAS
+6 ;
SHOWIT ; EP
+1 SET LRAAIEN=LRAN_","_LRAD_","_LRAA
+2 SET LRDFN=$$GET1^DIQ(68.02,LRAAIEN,.01,"I")
+3 SET LRIDT=$$GET1^DIQ(68.02,LRAAIEN,13.5,"I")
+4 SET LRDATA=$ORDER(^LR(LRDFN,"CH",LRIDT,"A"),-1)
+5 SET BLRTXLOG=$ORDER(^BLRTXLOG("D",LRAS,0))
+6 SET VLABIEN=$$GET1^DIQ(9009022,BLRTXLOG,105,"I")
+7 ;
+8 WRITE !,?4,"Accession:",$$GET1^DIQ(63.04,LRIDT_","_LRDFN,.06),!
+9 WRITE ?8,
