Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BLRPOC3

BLRPOC3.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  Q
  1.  ;
  1.  ; IHS/MSC/MKK
  1.  ;      TEST subroutine moved to this routine due to the BLRPOC routine
  1.  ;      becoming too large (i.e., violated SAC guidelines).
  1.  ;
  1. 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)
  1.  ;
  1.  K ^TMP("BLRDIAG",$J)   ; Make sure Diagnosis is cleared.
  1.  ;
  1.  W !!,"POC Test."
  1.  S ARY("CD")=$$NOW^XLFDT
  1.  ;
  1.  Q:$$GETYVAL(60,.TESTY)<1
  1.  I $$CHKTST^BLRPOC(+TESTY)<1 D  Q
  1.  . D BADSTUFF("Test "_$$GET1^DIQ(60,TEST6,.01)_" ["_TESTY_"] cannot be used.")
  1.  ;
  1.  S ARY("ORDTST")=$G(TESTY)
  1.  ;
  1.  I $$ISPANEL^BLRPOC(+TESTY) S CONTINUE=$$GETCOSMC(TESTY,.ARY)
  1.  E  D
  1.  . S ARY("TST",1)=$G(TESTY)
  1.  . S CONTINUE=$$GETRESLT(+TESTY,.RESULTS,.COMMENT)
  1.  . I CONTINUE="OK" S ARY("RES",1)=RESULTS  S:RESULTS="*" ARY("CMT",1)=COMMENT
  1.  Q:$G(CONTINUE)="Q"
  1.  ;
  1.  S SITESPEC=$O(^LAB(60,+TESTY,1,0))
  1.  ;
  1.  S ARY("CM")=$$GET1^DIQ(61,SITESPEC,.01,"I")_U_$$GET1^DIQ(61,SITESPEC,.01)
  1.  S CSI=+$$GET1^DIQ(60,+TESTY,9,"I") ; Collection Sample IEN
  1.  I CSI<1 D
  1.  . S CSI=+$O(^LAB(60,+TESTY,3,0))
  1.  . S CSI=+$G(^LAB(60,+TESTY,3,CSI,0))
  1.  S ARY("COL")=CSI_U_$$GET1^DIQ(62,CSI,.01)
  1.  ;
  1.  Q:$$GETYVAL(44,.Y)<1
  1.  S ARY("LOC")=$G(Y)
  1.  ;
  1.  Q:$$GETYVAL(200,.Y,"PROVIDER")<1
  1.  S ARY("PRV")=$G(Y)
  1.  ;
  1.  Q:$$GETYVAL(100.02,.Y)<1
  1.  S ARY("NOO")=$G(Y)
  1.  ;
  1.  Q:$$GETYVAL(62.05,.Y)<1
  1.  S ARY("URG")=$G(Y)
  1.  ;
  1.  S COMMCNT=+$O(ARY("CMT","A"),-1)
  1.  I $G(ARY("CMT",COMMCNT))'["TEST^BLRPOC" D
  1.  . S ARY("CMT",COMMCNT+1)="Testing POC Code from TEST^BLRPOC entry."
  1.  ;
  1.  Q:$$GETYVAL(2,.Y)<1
  1.  S DFN=+$G(Y)
  1.  ;
  1.  S STR=$$CHKITOUT^BLRSGNSU(DFN,$$DT^XLFDT)
  1.  Q:STR=""
  1.  S STR1=$P(STR,U,2)
  1.  S ARY("SYMP")=STR1_U_$P(STR,U,3)_U_$P(STR,U)
  1.  ;
  1.  W !!,"Before SAVE call.",!
  1.  D ARRYDUMP("ARY")
  1.  D ^XBFMK
  1.  S DIR(0)="YO"
  1.  S DIR("A")="Make ARY(""CD"")=Just a Date"
  1.  D ^DIR
  1.  I +Y D
  1.  . S ARY("CD")=$P($G(ARY("CD")),".")
  1.  . D ARRYDUMP("ARY")
  1.  ;
  1.  D PRESSKEY^BLRGMENU(9)
  1.  ;
  1.  W !,"DFN:",DFN," - ",$P(Y,U,2),!
  1.  ;
  1.  D SAVE^BLRPOC(.RET,DFN,.ARY)
  1.  ;
  1.  W !,"After SAVE Call.",!
  1.  W ?4,"RET:",RET,!!
  1.  ;
  1.  S LRDFN=$$GET1^DIQ(2,DFN,63,"I")
  1.  S LRIDT=$O(^LR(LRDFN,"CH",0))
  1.  S LRAS=$$GET1^DIQ(63.04,LRIDT_","_LRDFN,.06)
  1.  ;
  1.  H 1
  1.  S BLRTXLOG=$O(^BLRTXLOG("D",LRAS,0))
  1.  I BLRTXLOG D
  1.  . S X=$$GETACCCP^BLRUTIL3(LRAS,.LRAA,.LRAD,.LRAN)
  1.  . D SHOWIT
  1.  . ; S VLABIEN=$$GET1^DIQ(9009022,BLRTXLOG,105,"I")
  1.  . ; W !,?4,"Latest Accession:",$$GET1^DIQ(63.04,LRIDT_","_LRDFN,.06),!
  1.  . ; W ?10,"BLRTXLOG:",BLRTXLOG,?30,"FLAG:",$$GET1^DIQ(9009022,BLRTXLOG,2002),!
  1.  . ; W ?9,"V LAB IEN:",VLABIEN,?30,"FLAG:",$$GET1^DIQ(9000010.09,VLABIEN,.05),!
  1.  E  W ?4,"Could not determine BLRTXLOG for Accession ",LRAS,!
  1.  ;
  1.  K ^TMP("BLRDIAG",$J)
  1.  Q
  1.  ;
  1. GETYVAL(FNUM,YVAL,PROMPT) ; EP - MSC/MKK - Make this a function and add ability to pass a prompt string.
  1.  D ^XBFMK
  1.  S DIR(0)="PO^"_FNUM_":EMZ"
  1.  S:$L($G(PROMPT)) DIR("A")=PROMPT
  1.  D ^DIR
  1.  I +$G(DIRUT) D INVALENT  Q 0
  1.  ;
  1.  S YVAL=$G(Y)
  1.  Q 1
  1.  ;
  1. INVALENT ; EP - Invalid Entry Prompt
  1.  W !,?4,"No/Quit Entry.  Routine Ends."
  1.  D PRESSKEY^BLRGMENU(9)
  1.  Q
  1.  ;
  1. ARRYDUMP(ARRY) ; EP - "Dump" the array
  1.  NEW STR1
  1.  ;
  1.  S STR1=$Q(@ARRY@(""))
  1.  W !,?5,ARRY,!
  1.  W ?10,STR1,"=",@STR1,!
  1.  F  S STR1=$Q(@STR1)  Q:STR1=""  D
  1.  . W ?10,STR1,"=",@STR1,!
  1.  Q
  1.  ;
  1.  ; --- BEGIN MSC/MKK - Allow COSMIC tests
  1. 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)
  1.  ;
  1.  S COSMCIEN=+$G(COSMCTST)
  1.  S (CNT,BAILOUT,PANELN)=0
  1.  F  S PANELN=$O(^LAB(60,COSMCIEN,2,PANELN))  Q:PANELN<1!(BAILOUT)  D
  1.  . S PANELIEN=PANELN_","_COSMCIEN
  1.  . S F60IEN=$$GET1^DIQ(60.02,PANELIEN,.01,"I")
  1.  . ; I $$GETRESLT(F60IEN,.RESULTS)="Q" S BAILOUT=BAILOUT+1  Q
  1.  . I $$GETRESLT(F60IEN,.RESULTS,.COMMENT)="Q" S BAILOUT=BAILOUT+1  Q      ; MSC/MKK - LR*5.2*XXXX
  1.  . ;
  1.  . S CNT=CNT+1
  1.  . S TESTSTR=F60IEN_U_$$GET1^DIQ(60,F60IEN,.01)
  1.  . S ARRAY("TST",CNT)=$G(TESTSTR)
  1.  . S ARRAY("RES",CNT)=RESULTS
  1.  . S:RESULTS="*" ARRAY("CMT",CNT)=COMMENT   ; MSC/MKK - LR*5.2*XXXX
  1.  ;
  1.  Q $S(BAILOUT:"Q",1:"OK")
  1.  ;
  1. GETRESLT(IEN,RESULT,COMMENT) ; EP - Get Result Value
  1.  NEW TESTNAME
  1.  ;
  1.  S COMMENT=""
  1.  S TESTNAME=$$GET1^DIQ(60,IEN,.01)
  1.  ;
  1.  D ^XBFMK
  1.  S DIR(0)="FO",DIR("A")=TESTNAME_"'s Result Text or Number"
  1.  D ^DIR
  1.  I +$G(DIRUT) D INVALENT  Q "Q"
  1.  S RESULT=$G(Y)
  1.  ;
  1.  I RESULT="*" D
  1.  . D ^XBFMK
  1.  . S DIR(0)="FO",DIR("A")="Comment for cancelled result"
  1.  . D ^DIR
  1.  . S COMMENT=$S($L($G(X)):$G(X),1:"Cancelled")
  1.  ;
  1.  Q "OK"
  1.  ;
  1. BADSTUFF(STR,TAB) ; EP - BADSTUFF error message
  1.  S TAB=$S($L($G(TAB))<1:4,1:TAB)
  1.  W !!,?TAB,STR,"  Routine Ends."
  1.  D PRESSKEY^BLRGMENU(TAB+5)
  1.  Q
  1.  ;
  1. SHOWFLAG ; EP - Given Accession number, show V LAB FLAG
  1.  NEW BLRLRAS,BLRTXLOG,LRAA,LRAAIEN,LRAD,LRDATA,LRAN,LRAS,VLABIEN
  1.  ;
  1.  W !!
  1.  D ^LRWU4
  1.  S LRAS=BLRLRAS
  1.  ;
  1. SHOWIT ; EP
  1.  S LRAAIEN=LRAN_","_LRAD_","_LRAA
  1.  S LRDFN=$$GET1^DIQ(68.02,LRAAIEN,.01,"I")
  1.  S LRIDT=$$GET1^DIQ(68.02,LRAAIEN,13.5,"I")
  1.  S LRDATA=$O(^LR(LRDFN,"CH",LRIDT,"A"),-1)
  1.  S BLRTXLOG=$O(^BLRTXLOG("D",LRAS,0))
  1.  S VLABIEN=$$GET1^DIQ(9009022,BLRTXLOG,105,"I")
  1.  ;
  1.  W !,?4,"Accession:",$$GET1^DIQ(63.04,LRIDT_","_LRDFN,.06),!
  1.  W ?8, "LAB DATA RESULT:",$P($G(^LR(LRDFN,"CH",LRIDT,LRDATA)),U),?35,"FLAG:",$P($G(^(LRDATA)),U,2),!
  1.  W ?15,"BLRTXLOG:",BLRTXLOG,?35,"FLAG:",$$GET1^DIQ(9009022,BLRTXLOG,2002),!
  1.  W ?14,"V LAB IEN:",VLABIEN,?35,"FLAG:",$$GET1^DIQ(9000010.09,VLABIEN,.05),!
  1.  D PRESSKEY^BLRGMENU(4)
  1.  Q