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