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

BLRAAORU.m

Go to the documentation of this file. 
  1. BLRAAORU ;IHS/OIT/MKK - IHS LAB ASK-AT-ORDER UTILITIES ; JUL 06, 2011 3:15 PM
  1.  ;;5.2;IHS LABORATORY;**1030,1031**;NOV 01, 1997
  1.  ;
  1.  Q
  1.  ;
  1. UPDTCOML(LRDFN,LRIDT,LRODT,LRSP) ; EP - Update the Comment line(s)
  1.  NEW ANSWER,ASKORDQ,DIE,ERRCNT,ERRS,FDA,IENS,ORD,P60,P60DESC,P60BORDR,QUESCNT
  1.  ;
  1.  ; Skip if nothing stored
  1.  Q:$D(^BLRAAOQD(LRODT,LRSP))<1
  1.  ;
  1.  S (ERRCNT,ORD,P60,QUESTCNT)=0
  1.  F  S P60=$O(^BLRAAOQD(LRODT,LRSP,P60))  Q:P60<1  D
  1.  . F  S ORD=$O(^BLRAAOQD(LRODT,LRSP,P60,ORD))  Q:ORD<1  D
  1.  .. S ASKORDQ=$G(^BLRAAOQD(LRODT,LRSP,P60,ORD))
  1.  .. D ADDCOMNT(ASKORDQ,.ERRCNT)
  1.  .. S QUESTCNT=QUESTCNT+1
  1.  ;
  1.  ; Data has been stored & no errors: clear out data global
  1.  K:ERRCNT<1 ^BLRAAOQD(LRODT,LRSP)
  1.  Q
  1.  ;
  1. ADDCOMNT(WOT,ERRCNT) ; EP - Add the comment
  1.  NEW RJAMT
  1.  ;
  1.  ; Right Justify Date/Time amount
  1.  ; Note: The +5 is the size difference between $H & MM/DD/YYYY@HH:MM
  1.  S RJAMT=$J("",(69-($L(WOT)+5)))
  1.  S:$L(RJAMT)<1 RJAMT="  "           ; Failsafe - need at least 1 space
  1.  ;
  1.  ; Change $H to external Date/Time
  1.  S $P(WOT,"^",3)=RJAMT_$$HTE^XLFDT($P(WOT,"^",3),"5MZ")
  1.  ;
  1.  S IENS(1)=$O(^LR(LRDFN,"CH",LRIDT,1,"B"),-1)+1  ; Get next COMMENT line
  1.  S FDA(63.041,"+1,"_LRIDT_","_LRDFN_",",.01)=$TR(WOT,"^"," ")
  1.  ;
  1.  D UPDATE^DIE(,"FDA","IENS","ERRS")
  1.  ;
  1.  D:$D(ERRS("DIERR"))>0 ADDERRS(WOT,.ERRS,.ERRCNT)   ; Errors
  1.  Q
  1.  ;
  1. ADDERRS(WOT,ERRS,ERRCNT) ; EP -- Add Errors.  Send Alert & Email
  1.  NEW LRAA,LRAD,LRAN,LRAS,STR,TAB,TST
  1.  ;
  1.  S ERRCNT=ERRCNT+1
  1.  ;
  1.  ; Store data for report
  1.  M ^BLRAAORE(LRDFN,LRIDT,LRODT,LRSP,P60,ORD)=ERRS
  1.  ;
  1.  S TST=+$O(^LRO(LRODT,1,LRSP,2,"B",P60,0))
  1.  I TST<1 D  Q
  1.  . K STR
  1.  . S TAB=$J("",7)
  1.  . S STR(1)="In ADDCOMNT^BLRAAOQD:"
  1.  . S STR(2)=" "
  1.  . S STR(3)=TAB_"LRDFN:"_LRDFN
  1.  . S STR(4)=TAB_"LRIDT:"_LRIDT
  1.  . S STR(5)=TAB_"LRODT:"_LRODT
  1.  . S STR(6)=TAB_"LRSP:"_LRSP
  1.  . S STR(7)=TAB_"P60:"_P60
  1.  . S STR(8)=TAB_"ORD:"_ORD
  1.  . S STR(9)=TAB_"WOT:"_WOT
  1.  . D SENDMAIL^BLRUTIL3("Invalid Ask-at-Order TEST",.STR,"BLRAAORU")
  1.  . D SNDALERT^BLRUTIL3("ADDCOMNT^BLRAAOQD: Invalid Ask-at-Order TEST. Email Sent.")
  1.  ;
  1.  S STR=$G(^LRO(LRODT,1,LRSP,2,TST,0))
  1.  S LRAA=$P(STR,"^",5),LRAD=$P(STR,"^",4),LRAN=$P(STR,"^",6)
  1.  S LRAS=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
  1.  ;
  1.  D SNDALERT^BLRUTIL3("Invalid Ask-at-Order Update for Accession "_LRAS)
  1.  Q
  1.  ;
  1.  ; The IEN of the test must be passed to the routine
  1. ASKQUES(P60,LRODT,LRSP,ORDNUM) ; EP - Ask the question(s) for a SPECIFIC test
  1.  NEW ANSWERS,BAILOUT,CNT,CURANS,DATANAME,DEF,DZERO,ORDER,PTR,QUESDESC,QUESORD,QUEST
  1.  NEW READWHAT,STORQUES,STR,TYPE,UCUM,UNITS
  1.  ;
  1.  S DZERO=$O(^BLRAAOQ("B",+$G(P60),""))
  1.  Q:DZERO<1                                    ; If not in Lab Ask-At-Order dictionary, skip
  1.  ;
  1.  I +$G(ORDNUM)>0&((+$G(LRODT)<1)!(+$G(LRSP)<1))  D GETDTSP(ORDNUM,P60,.LRODT,.LRSP)
  1.  Q:+$G(LRODT)<1!(+$G(LRSP)<1)                 ; If LRODT or LRSP null, skip
  1.  ;
  1.  Q:$D(^BLRAAOQD(LRODT,LRSP,P60))              ; If Question already asked, skip
  1.  ;
  1.  S (CNT,BAILOUT,QUESORD)=0
  1.  ;
  1.  F  S QUESORD=$O(^BLRAAOQ(DZERO,1,QUESORD))  Q:QUESORD<1!(BAILOUT)  D
  1.  . D QUESASK(.ANSWERS,DZERO,QUESORD,.CNT,P60)
  1.  ;
  1.  D CORRAANS(.ANSWERS)
  1.  ;
  1.  D STOREANS(P60,.ANSWERS,LRODT,LRSP)
  1.  ;
  1.  Q
  1.  ;
  1. QUESASK(ANSWERS,DZERO,QUESORD,CNT,P60)   ; EP - Single Question
  1.  S STR=$G(^BLRAAOQ(DZERO,1,QUESORD,0))
  1.  S (STORQUES,QUEST)=$P(STR,"^",1)           ; Question
  1.  S:STORQUES'["?" STORQUES=STORQUES_"?"      ; Make sure Question ends with a question mark
  1.  S TYPE=$P(STR,"^",2)                       ; Type of Question
  1.  S DEF=$P(STR,"^",3)                        ; Default value, if any
  1.  S PTR=+$P(STR,"^",4)                       ; Pointer to Dictionary
  1.  S UCUM=+$P(STR,"^",5)                      ; Pointer to IHS UCUM (#90475.3) file
  1.  S UNITS=$$GET1^DIQ(90475.3,UCUM_",",3)     ; UCUM Print String
  1.  ;
  1.  S READWHAT=$S($L(TYPE):TYPE,1:"F")_"AO"    ; Type of Answer -- null implies free text
  1.  ; S:PTR>0 READWHAT=READWHAT_"^"_PTR        ; If & only if PTR exists
  1.  S:PTR>0 READWHAT=READWHAT_"^"_PTR_":E"     ; If & only if PTR exists; Allow lowercase & abbreviation selections -- LR*5.2*1031
  1.  S:TYPE="N" READWHAT=READWHAT_"^::2"        ; If numeric, allow up to 2 decimals
  1.  ;
  1.  ; Reset Question string
  1.  S:$L(UNITS) QUEST=$P(QUEST,"?")_" ("_UNITS_")?"
  1.  ;
  1.  ; Display notice first time through
  1.  D:CNT<1 ASKNOTCE^BLRAAORU(P60)
  1.  ;
  1.  S CNT=CNT+1
  1.  D ^XBFMK
  1.  S DIR(0)=READWHAT
  1.  S DIR("A")=QUEST_" "
  1.  S:$L(DEF) DIR("B")=$G(DEF)
  1.  D ^DIR
  1.  ;
  1.  S CURANS=""
  1.  I $L(Y)>0 D
  1.  . S:TYPE="D" X=$$FMTE^XLFDT(Y,"5DZ")              ; Store date as MM/DD/YYYY
  1.  . S CURANS=$S(PTR<1:$G(X),1:$P($G(Y),"^",2))      ; Store text.  If pointer, store text, not IEN
  1.  . S:$L(UNITS)>0 CURANS=CURANS_" ("_UNITS_")"      ; If there are units, store next to answer
  1.  . I READWHAT'["YES/NO"  D                         ; If YES/NO type of question, do the following
  1.  .. S:$G(CURANS)="Y" CURANS="YES"                  ; If Y for yes, then store YES
  1.  .. S:$G(CURANS)="N" CURANS="NO"                   ; If N for no, then store NO
  1.  ;
  1.  ; Store ALL answers, even if NULL
  1.  S ANSWERS(QUESORD)=STORQUES_"^"_CURANS_"^"_$H   ; Store Date/Time of answer
  1.  Q
  1.  ;
  1. CORRAANS(ANSARRAY) ; EP - Determine if any changes are needed to answers
  1.  NEW ALLOKAY
  1.  ;
  1.  S ALLOKAY=0
  1.  F  Q:ALLOKAY  D
  1.  . D SHOWANSA(.ANSARRAY,.HOWMANY)
  1.  . D ^XBFMK
  1.  . S DIR(0)="NO^1:"_HOWMANY
  1.  . S DIR("B")=HOWMANY
  1.  . D ^DIR
  1.  . I +$G(Y)=HOWMANY!(+$G(Y)<1) S ALLOKAY=1  Q
  1.  . ;
  1.  . W !!
  1.  . D QUESASK(.ANSARRAY,DZERO,+$G(Y),2,P60)
  1.  Q
  1.  ;
  1. SHOWANSA(ANSARRAY,HOWMANY) ; EP - Display ANSWERS Array
  1.  W !!!,?9,"Correct which Lab Ask-At-Order Answer?",!!
  1.  W " #",?4,"Question",?66,"Answer",!
  1.  W ?4,$TR($J("",60)," ","-"),?66,$TR($J("",14)," ","-"),!
  1.  S QUESORD=0
  1.  F  S QUESORD=$O(ANSARRAY(QUESORD))  Q:QUESORD<1  D
  1.  . S STR=$G(ANSARRAY(QUESORD))
  1.  . W $J(QUESORD,2),")",?4,$E($P(STR,"^"),1,60),?66,$E($P(STR,"^",2),1,14),!
  1.  . S HOWMANY=QUESORD
  1.  S HOWMANY=HOWMANY+1
  1.  W !,$J(HOWMANY,2),")",?4,"None.  All Answers are correct.",!
  1.  W !!
  1.  Q
  1.  ;
  1. GETDTSP(ORDNUM,P60,LRODT,LRSP) ; EP -- Have Order # & Test: Need LRODT & LRSP
  1.  NEW PTR,FOUNDIT,TEST
  1.  ;
  1.  S LRODT="",FOUNDIT=0
  1.  F  S LRODT=$O(^LRO(69,"C",ORDNUM,LRODT))  Q:LRODT<1!(FOUNDIT)  D
  1.  . S LRSP=.9999999
  1.  . S LRSP=$O(^LRO(69,"C",ORDNUM,LRODT,LRSP))  Q:LRSP<1!(FOUNDIT)  D
  1.  .. S TEST=.9999999
  1.  .. F  S TEST=$O(^LRO(69,LRODT,1,LRSP,2,TEST))  Q:TEST<1!(FOUNDIT)  D
  1.  ... I +$G(^LRO(69,LRODT,1,LRSP,2,TEST,0))=P60  S FOUNDIT("LRODT")=LRODT,FOUNDIT("LRSP")=LRSP,FOUNDIT=1  Q
  1.  ;
  1.  S:FOUNDIT LRODT=$G(FOUNDIT("LRODT")),LRSP=$G(FOUNDIT("LRSP"))
  1.  Q
  1.  ;
  1. ASKNOTCE(P60)  ; EP - Notice that the test has been tagged as an ASK-AT-ORDER test
  1.  W !!,"NOTICE:",!
  1.  W ?4,"The test ",!
  1.  W ?9,$P($G(^LAB(60,P60,0)),"^")," [",P60,"]",!
  1.  W ?4,"has been designated a Lab Ask-At-Order test and, as such,",!
  1.  W ?4,"has questions that should be answered at ordering.",!!
  1.  W ?4,"Please  note that if you press the RETURN key, a null",!
  1.  W ?4,"answer is stored.",!!
  1.  Q
  1.  ;
  1.  ; Have to use Order Date & Number to keep unique
  1. STOREANS(P60,ANSWERS,LRODT,LRSP) ; EP - Store Answers into AAO data file
  1.  NEW CNT,ORD
  1.  K ^BLRAAOQD(LRODT,LRSP)
  1.  ;
  1.  S ^BLRAAOQD(LRODT,LRSP,P60,1)="The following Lab ASK AT ORDER Questions"
  1.  S ^BLRAAOQD(LRODT,LRSP,P60,2)="Answered by "_$P($G(^VA(200,DUZ,0)),"^")_" ("_DUZ_"):"
  1.  ;
  1.  S ORD=0,CNT=2
  1.  F  S ORD=$O(ANSWERS(ORD))  Q:ORD<1  D
  1.  . S CNT=CNT+1
  1.  . S ^BLRAAOQD(LRODT,LRSP,P60,CNT)=$J("",3)_$G(ANSWERS(ORD))
  1.  Q
  1.  ;
  1. LISTCOML(LRDFN,LRIDT) ; EP - List Comments from Lab Data File
  1.  W !!,"Value in ^LR(",LRDFN,",",$C(34),"CH",$C(34),",",LRIDT,"):",!
  1.  S COMMENT=.9999999
  1.  F  S COMMENT=$O(^LR(LRDFN,"CH",LRIDT,1,COMMENT))  Q:COMMENT<1  D
  1.  . W ?2,COMMENT,?4,$E($G(^LR(LRDFN,"CH",LRIDT,1,COMMENT,0)),1,77),!
  1.  Q
  1.  ;
  1. LISTCOMA(LRAS) ; EP - List Comments from Lab Data File given Accession Number
  1.  NEW LRAA,LRAD,LRAN,LRDFN,LRIDT
  1.  ;
  1.  D GETACCCP^BLRUTIL3(LRAS,.LRAA,.LRAD,.LRAN)
  1.  I LRAA<1!(LRAD<1)!(LRAN<1) D  Q
  1.  . W !,"Invalid Accession Number.",!
  1.  . D PRESSKEY^BLRGMENU(4)
  1.  ;
  1.  S LRDFN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
  1.  S LRIDT=+$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5)
  1.  I LRDFN<1!(LRIDT<1) D  Q
  1.  . W !,"Could not determine LRDFN and/or LRIDT.",!
  1.  . D PRESSKEY^BLRGMENU(4)
  1.  ;
  1.  W !!,"Value in ^LR(",LRDFN,",",$C(34),"CH",$C(34),",",LRIDT,"):",!
  1.  S COMMENT=.9999999
  1.  F  S COMMENT=$O(^LR(LRDFN,"CH",LRIDT,1,COMMENT))  Q:COMMENT<1  D
  1.  . W ?2,COMMENT,?4,$E($G(^LR(LRDFN,"CH",LRIDT,1,COMMENT,0)),1,77),!
  1.  Q
  1.  ;
  1. ASKATORD(LRORD) ; EP - If have Order Number, Lab Ask-At-Order Questions
  1.  NEW LRODT,LRSP,TSTORD,PTR
  1.  ;
  1.  Q:+$G(LRORD)<1           ; Failsafe
  1.  ;
  1.  S LRODT=.9999999
  1.  F  S LRODT=$O(^LRO(69,"C",LRORD,LRODT))  Q:LRODT<1  D
  1.  . S LRSP=.9999999
  1.  . F  S LRSP=$O(^LRO(69,"C",LRORD,LRODT,LRSP))  Q:LRSP<1  D
  1.  .. S TST=.9999999
  1.  .. F  S TST=$O(^LRO(69,LRODT,1,LRSP,2,TST))  Q:TST<1  D
  1.  ... S PTR=+$G(^LRO(69,LRODT,1,LRSP,2,TST,0))
  1.  ... D:PTR>0 ASKQUES^BLRAAORU(PTR,LRODT,LRSP,LRORD)
  1.  ;
  1.  Q
  1.  ;
  1. ERRSPURG ; EP - Purge Errors Global
  1.  NEW HEADER,LINES,MAXLINES,PG,QFLG,STR
  1.  D ERRSPURI
  1.  D HEADERDT^BLRGMENU
  1.  ;
  1.  Q:$$ERRPURYN("Do you want to purge the Lab Ask At Order Error (LAAOE) File")<1
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  Q:$$ERRPURYN("Are you CERTAIN you want to purge the LAAOE File")<1
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  Q:$$ERRPURYN("LAST CHANCE: Are you really certain you want to purge the LAAOE File")<1
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  W !!,"Very Well.  LAAOE File Purged.",!!
  1.  ;
  1.  S STR="^BLRAAORE"
  1.  K @STR
  1.  ;
  1.  D PRESSKEY^BLRGMENU(4)
  1.  ;
  1.  Q
  1.  ;
  1. ERRSPURI ; EP -- Initialize variables
  1.  S HEADER(1)="Lab Ask At Order Questions"
  1.  S HEADER(2)="Purge Errors File"
  1.  ;
  1.  S MAXLINES=22,LINES=MAXLINES+10,PG=0,QFLG="NO"
  1.  Q
  1.  ;
  1. ERRPURYN(QUES) ; EP -- Questions
  1.  NEW RESPONSE
  1.  ;
  1.  D ^XBFMK
  1.  S DIR(0)="YO"
  1.  S DIR("A")=$J("",4)_QUES
  1.  D ^DIR
  1.  S RESPONSE=+$G(Y)
  1.  I +$G(Y)<1 D
  1.  . W !!!,?9,"Quit/No/Invalid response. Routine Ends."
  1.  . D PRESSKEY^BLRGMENU(9)
  1.  Q RESPONSE
  1.  ;
  1. TASKPURG ; EP -- Tasked entry point for purging the ^BLRAAORE file.
  1.  NEW STR
  1.  ;
  1.  S STR="^BLRAAORE"
  1.  K @STR
  1.  ;
  1.  S STR(1)="Lab Ask-at-Order File (^BLRAAORE) has been purged."
  1.  S STR(2)=" "
  1.  S STR(3)=$J("",10)_"DATE:"_$$HTE^XLFDT($H,"5DZ")
  1.  S STR(4)=$J("",10)_"TIME:"_$P($$HTE^XLFDT($H,"5MZ"),"@",2)
  1.  ;
  1.  D SENDMAIL^BLRUTIL3("Lab Ask-at-Order Task",.STR,"BLRAAORE","NO")
  1.  Q
  1.  ;
  1. ORDNSTOR(LRORD) ; EP -- Store Ask at Order questions given Lab Order Number
  1.  NEW LRAA,LRAD,LRAN,LRAS,LRIDT,LRODT,LRSP,PTR,STR,TST
  1.  ;
  1.  S LRODT=.9999999
  1.  F  S LRODT=$O(^LRO(69,"C",LRORD,LRODT))  Q:LRODT<1  D
  1.  . S LRSP=.9999999
  1.  . F  S LRSP=$O(^LRO(69,"C",LRORD,LRODT,LRSP))  Q:LRSP<1  D
  1.  .. Q:$D(^BLRAAOQD(LRODT,LRSP))<10       ; Can be called inappropriately due to LAB calling routines
  1.  .. S TST=.999999
  1.  .. F  S TST=$O(^LRO(69,LRODT,1,LRSP,2,TST))  Q:TST<1  D
  1.  ... S STR=$G(^LRO(69,LRODT,1,LRSP,2,TST,0))
  1.  ... S LRAD=+$P(STR,"^",3),LRAA=+$P(STR,"^",4),LRAN=+$P(STR,"^",5)
  1.  ... S LRAS=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
  1.  ... Q:$L(LRAS)<1
  1.  ... ;
  1.  ... S LRDFN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
  1.  ... S LRIDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5)
  1.  ... D UPDTCOML(LRDFN,LRIDT,LRODT,LRSP)
  1.  ;
  1.  Q
  1.  ;
  1. UPDTAAOQ ; EP - Try to update the Lab Data file with entries in the BLRAAORD file
  1.  NEW CNT,LRODT,LRSP,P60,LRORD
  1.  ;
  1.  S CNT=0
  1.  S (LRODT,LRSP,P60,LRORD)=.9999999
  1.  F  S LRODT=$O(^BLRAAOQD(LRODT))  Q:LRODT<1  D
  1.  . F  S LRSP=$O(^BLRAAOQD(LRODT,LRSP))  Q:LRSP<1  D
  1.  .. F  S P60=$O(^BLRAAOQD(LRODT,LRSP,P60))  Q:P60<1  D
  1.  ... F  S LRORD=$O(^BLRAAOQD(LRODT,LRSP,P60,LRORD))  Q:LRORD<1  D
  1.  .... D ORDNSTOR(LRORD)
  1.  .... S CNT=CNT+1
  1.  ;
  1.  W "CNT:",CNT,!
  1.  Q
  1.  ;
  1. GETLRAS(LRORD) ; EP -- Get the Accession(s) tied to an Order
  1.  NEW LRAA,LRAD,LRAN,LRAS,LRIDT,LRODT,LRSP,PTR,STR,TST
  1.  ;
  1.  S LRODT=.9999999
  1.  F  S LRODT=$O(^LRO(69,"C",LRORD,LRODT))  Q:LRODT<1  D
  1.  . S LRSP=.9999999
  1.  . F  S LRSP=$O(^LRO(69,"C",LRORD,LRODT,LRSP))  Q:LRSP<1  D
  1.  .. S TST=.999999
  1.  .. F  S TST=$O(^LRO(69,LRODT,1,LRSP,2,TST))  Q:TST<1  D
  1.  ... S STR=$G(^LRO(69,LRODT,1,LRSP,2,TST,0))
  1.  ... S LRAD=+$P(STR,"^",3),LRAA=+$P(STR,"^",4),LRAN=+$P(STR,"^",5)
  1.  ... S LRAS=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
  1.  ... S LRDFN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
  1.  ... S LRIDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5)
  1.  ... W LRORD
  1.  ... W ?9,$S(LRAA>0:LRAA,1:"")
  1.  ... W ?14,$S(LRAD>0:LRAD,1:"")
  1.  ... W ?24,$S(LRAN>0:LRAN,1:"")
  1.  ... W ?34,$S($G(LRAN)'="":LRAS,1:"")
  1.  ... W ?54,LRDFN
  1.  ... W ?64,LRIDT
  1.  ... W !
  1.  Q