BLRDIAG ;IHS/ITSC/TPF - MAIN 'SIGN OR SYMPTOM' LAB POV INPUT ROUTINE; 22-Oct-2013 09:22 ; MKK
;;5.2;IHS LABORATORY;**1015,1017,1018,1019,1021,1027,1031,1033,1034**;NOV 01, 1997;Build 88
;
;NOTE: LRPOVREQ WAS USED AS A SITE PARAMETER DURING DEVELOPMENT.
;IT WAS THOUGHT THAT THIS REQUIREMENT WOULD BE DECIDED UPON BY EACH
;SITE. HOWEVER MED REC HAS DECIDED SINCE THIS IS REQUIRED BY LAW IT
;SHOULD NOT BE LEFT TO EACH SITE'S CHOICE TO REQUIRE THE FIELD OR
;NOT. THE VARIABLE HAS BEEN LEFT IN FOR ALPHA TESTING
Q
UPPER(X) ; EP
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
;
;AFTER THE ENTIRE ORDER IS COMPLETE LETS DO THE 'SIGN OR SYMPTOM'
;ALSO IF NEED BE CHECK TO SEE IF WE NEED TO ACCESSION THEM AS WELL (FAST E.G.)
COMPORD(LRODT,LRORD) ;EP CALLED FROM LRORDST
;
Q:$G(LRODT)=""!($G(LRORD)="")
;
;
N TMPCWL,TMPSET
D DIAG(LRODT,LRORD) ;IHS/ITSC/TPF ALLOW ENTRY OF 'SIGN OR SYMPTOM' LAB POV **1015*
;
I LRORDR="" D
.S ORDIEN="" F S ORDIEN=$O(^LRO(69,"C",LRORD,LRODT,ORDIEN)) Q:ORDIEN="" D
..;S LRSN=ORDIEN S LRPHSET=0 D ^LRWLST K LRPHSET
..;KILL LRNCWL TO MAKE SURE THE PROMPT TO ALLOW USER TO ENTER AN
..;NUMBER IS NOT DISPLAYED AT WL2+1^LRWLST
..;KILL LRPHSET TO MAKE SURE THE ACCESSION IS DISPLAYED AT
..;STWLN+8^LRWLST1
..;KILL LRNCWL TO MAKE SURE PROMPT FOR ENTRY # IS NOT ASKED
..S LRSN=ORDIEN S:$D(LRNCWL) TMPCWL=$G(LRNCWL) S:$D(LRPHSET) TMPSET=LRPHSET K LRNCWL,LRPHSET D ^LRWLST S:$D(TMPCWL) LRNCWL=TMPCWL S:$D(TMPSET) LRPHSET=TMPSET
;
Q
;
DIAG(LRODT,LRORD) ;EP CALLED FROM LROW2A,LRTSTSET
D ENTRYAUD^BLRUTIL("DIAG^BLRDIAG 0.0")
;
Q:$G(LRODT)=""!($G(LRORD)="")
;
D ENTRYAUD^BLRUTIL("DIAG^BLRDIAG 1.0")
;
;DO WE HAVE MULTIPLE ENTRIES WE NEED TO ADD THE DIAG TO?
S MULTIPL=0
D MULTTST(LRORD,LRODT,.MULTIPL)
;
;----- BEGIN IHS MODIFICATIONS LR*5.2*1019 -- Patient Chart Mod
G:$G(BLRGUI) RPT
;----- END IHS MODIFICATIONS LR*5.2*1019 -- Patient Chart Mod
;
;IHS/ITSC/TPF 'SIGN OR SYMPTOM' LABPOV **1015**
D ENTRYAUD^BLRUTIL("DIAG^BLRDIAG 2.0")
;
W !!
S ASKALL=0 ;IHS/ITSC/TPF ASSUME USER WANTS SAME DIAG FOR ALL TESTS
I MULTIPL D Q:$D(DUOUT)!$D(DTOUT)
.;----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1021 -- Yes or No ONLY
YNONLY . ;
.;----- END IHS/OIT/MKK MODIFICATION LR*5.2*1021
.K STUFF
.K DIR
.; S DIR("A")="Do you want to enter a different Sign or Symptom for each test?"
.S DIR("A")="Do you want to enter a different Clinical Indication for each test?" ; IHS/MSC/MKK - LR*5.2*1034
.S DIR("B")="N"
.S DIR(0)="Y"
.D ^DIR
.;----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1021 -- Yes or No ONLY
.I X'="Y"&(X'="N") G YNONLY ; Only "Y" or "N" allowed
.;----- END IHS/OIT/MKK MODIFICATION LR*5.2*1021
.S ASKALL=Y
;
I ASKALL S BLRRLASK=1 ;cmi/anch/maw 5/22/2008 for reference lab
I ASKALL D ASK(LRORD,LRODT,1,.MULTIPL) W !! Q
;
;EXECUTION FALLS TO HERE IF A "BLANKET" DIAGNOSIS IS TO BE ENTERED
;FOR THE ENTIRE ORDER
RPT ;
S LRPOVREQ=1
K DIR,STUFF
;----- BEGIN IHS MODIFICATIONS LR*5.2*1019 -- Patient Chart Mod
I $G(BLRGUI) Q:BPCCOM="" D ASK(LRORD,LRODT,0,.MULTIPL,BPCCOM) Q
;----- END IHS MODIFICATIONS LR*5.2*1019 -- Patient Chart Mod
;
; S DIR("A",1)="Enter Sign or Symptom for LAB Order number "_LRORD
; S DIR("A")="(DO NOT USE 'RULE OUT', 'PROBABLE', 'QUESTIONABLE', etc.)"
; S DIR(0)="69.03,9999999.1^^"_$P(^DD(69.03,9999999.1,0),U,5)
; W !
; D ^DIR
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
; D ASKLPOV("Enter Sign or Symptom for LAB Order number "_LRORD)
; ----- END IHS/MSC/MKK - LR*5.2*1031
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
S ^TMP("BLRDIAG",$J,"ORDER")=LRORD
S ^TMP("BLRDIAG",$J,"ORDER","ALLTESTS")="YES"
S X=$$ALLTESTS^BLRSGNSY(DFN,LRORD,LRODT)
D:X GETRID^BLRSGNSP(LRORD)
Q
; ----- END IHS/MSC/MKK - LR*5.2*1033
;
I Y[U S LRNOP=0 D CANORD(LRODT,LRORD) W !!,"ORDER CANCELED!!" Q ;ADDED 12/30/02
I $G(LRPOVREQ),($D(DUOUT)!$D(DTOUT)!(Y="")) W !,"This is a required response." G RPT
; I Y=""!(Y[U) W !!,"No Sign or Symptom entered for order number "_LRORD,!! Q
I Y=""!(Y[U) W !!,"No Clinical Indication entered for order number "_LRORD,!! Q ; IHS/MSC/MKK - LR*5.2*1034
S STUFF=Y
K DIR
S DIR(0)="Y"
S DIR("B")="YES"
S DIR("A")="Is this correct"
D ^DIR
G:'Y RPT
;
D ASK(LRORD,LRODT,0,.MULTIPL,STUFF)
W !!
Q
;
;DO WE HAVE MULTIPLE TESTS FOR THIS ORDER?
MULTTST(LRORD,LRODT,MULTIPL) ;
S ^TMP("BLRDIAG",$J,"ORDER")=LRORD
;
S ORDIEN="" F I=1:1 S ORDIEN=$O(^LRO(69,"C",LRORD,LRODT,ORDIEN)) Q:ORDIEN="" D Q:MULTIPL
.I I>1 S MULTIPL=1 Q
.S TST="" F J=1:1 S TST=$O(^LRO(69,LRODT,1,ORDIEN,2,"B",TST)) Q:TST="" D Q:MULTIPL
..I J>1 S MULTIPL=1 Q
Q
;
;GO THROUGH ORDER D FOR EACH TEST AND PROMPT IF ASKING AND STUFF IF NOT
ASK(LRORD,LRODT,ASK,MULTIPL,STUFF) ; EP
D ENTRYAUD^BLRUTIL("ASK^BLRDIAG 0.0")
;
N I,J,ORDIEN,TST,SEQ,Y,DFNFLAG
NEW BAILOUT ; IHS/MSC/MKK - LR*5.2*1033
;
I +$G(DFN)<1 D
. S LRSP=$O(^LRO(69,"C",LRORD,LRODT,0))
. S LRDFN=+$G(^LRO(69,LRODT,1,LRSP,0))
. S DFN=+$P($G(^LR(LRDFN,0)),"^",3)
. S DFNFLAG=1
;
S ^TMP("BLRDIAG",$J,"ORDER")=LRORD ; IHS/MSC/MKK - LR*5.2*1033
S BAILOUT=0 ; IHS/MSC/MKK - LR*5.2*1033
S STUFF=$$UPPER($G(STUFF))
; S ORDIEN="" F I=1:1 S ORDIEN=$O(^LRO(69,"C",LRORD,LRODT,ORDIEN)) Q:ORDIEN="" D
; S ORDIEN="" F S ORDIEN=$O(^LRO(69,"C",LRORD,LRODT,ORDIEN)) Q:ORDIEN="" D ; IHS/OIT/MKK - LR*5.2*1031
S ORDIEN="" F S ORDIEN=$O(^LRO(69,"C",LRORD,LRODT,ORDIEN)) Q:ORDIEN=""!(BAILOUT) D ; IHS/MSC/MKK - LR*5.2*1033
.; S TST="" F J=1:1 S TST=$O(^LRO(69,LRODT,1,ORDIEN,2,"B",TST)) Q:TST="" D
.; S TST="" F S TST=$O(^LRO(69,LRODT,1,ORDIEN,2,"B",TST)) Q:TST="" D ; IHS/OIT/MKK - LR*5.2*1031
.S TST=0 F S TST=$O(^LRO(69,LRODT,1,ORDIEN,2,TST)) Q:TST<1!(BAILOUT) D ; IHS/MSC/MKK - LR*5.2*1033
.. ;
.. ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
.. W !!,?4,"SIGN/SYMPTOM FOR TEST: ",$$GET1^DIQ(69.03,TST_","_ORDIEN_","_LRODT_",","TEST/PROCEDURE")
.. S BAILOUT=$$GETSDIAG^BLRSGNSY(DFN,LRORD,LRODT,ORDIEN,TST)
.. Q
.. ; ----- END IHS/MSC/MKK - LR*5.2*1033
.. ;
..S DA=$O(^LRO(69,LRODT,1,ORDIEN,2,"B",TST,""))
..S DIE="^LRO(69,"_LRODT_",1,"_ORDIEN_",2,"
..I ASK D Q
...S DEF=$G(^LRO(69,LRODT,1,ORDIEN,2,DA,9999999))
...D ASK1(.STUFF,TST,DEF,ORDIEN,DA)
...Q:$G(Y)[U ;IF TRUE TEST HAS BEEN CANCELLED
...S DR="9999999.1///^S X=STUFF"
...;----- BEGIN IHS MODIFICATIONS LR*5.2*1019 -- Patient Chart Mod
...; L +^LRO(69,LRODT,1,ORDIEN):1 I '$T W !,"ORDER IS CURRENTLY BEING EDITED!" Q
...L +^LRO(69,LRODT,1,ORDIEN):1 I '$T W:'$G(BLRGUI) !,"ORDER IS CURRENTLY BEING EDITED!" S:$G(BLRGUI) RESULT(1)=-1,RESULT(2)="ORDER IS CURRENTLY BEING EDITED!" Q
...;----- END IHS MODIFICATIONS LR*5.2*1019 -- Patient Chart Mod
...D ^DIE L -^LRO(69,LRODT,1,ORDIEN)
..I 'ASK,($G(STUFF)'="") S DR="9999999.1///^S X=STUFF" D
...L +^LRO(69,LRODT,1,ORDIEN):1 I '$T W !,"ORDER IS CURRENTLY BEING EDITED!" Q
...D ^DIE L -^LRO(69,LRODT,1,ORDIEN)
;
K:+$G(DFNFLAG) LRDFN,DFN,LRSP
K I,J,ORDIEN,TST
K ^TMP("BLRDIAG",$J,"ORDER") ; IHS/MSC/MKK - LR*5.2*1033
Q
;
;PROMPT FOR 'SIGN OR SYMPTOM'
ASK1(STUFF,TST,DEF,ORDIEN,DA) ;
S LRPOVREQ=1
ASK1B K DIR
S STUFF=$$UPPER($G(STUFF))
; S DIR("B")=$G(DEF)
; S DIR("A",1)="Enter Sign or Symptom for "_$P($G(^LAB(60,TST,0)),U)
; S DIR("A")="(DO NOT USE 'RULE OUT', 'PROBABLE', 'QUESTIONABLE', etc.)"
; S DIR(0)="69.03,9999999.1^^"_$P(^DD(69.03,9999999.1,0),U,5)
; W !
; D ^DIR
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
; D ASKLPOV("Enter Sign or Symptom for "_$P($G(^LAB(60,TST,0)),U))
D ASKLPOV("Enter Clinical Indication for "_$P($G(^LAB(60,TST,0)),U)) ; IHS/MSC/MKK - LR*5.2*1034
; ----- END IHS/MSC/MKK - LR*5.2*1031
;
;I Y[U S LRNOP=0 D CANTST(ORDIEN,$S($G(DA)'="":DA,1:LRTN)) W !!,"TEST CANCELED FROM ORDER!!" Q ;ADDED 12/30/02
I Y[U S LRNOP=0 D CANTST(ORDIEN,$S($G(DA)'="":DA,$D(LRSN):LRSN,1:LRTN)) W !!,"TEST CANCELED FROM ORDER!!" Q ;IHS/ITSC/TPF 7/1/03 **1017**
I $G(LRPOVREQ),($D(DUOUT)!$D(DTOUT)!(Y="")) W !,"This is a required response." G ASK1B
; I Y=""!(Y[U) W !!,"No Sign or Symptom entered for "_$P($G(^LAB(60,TST,0)),U),!! Q
I Y=""!(Y[U) W !!,"No Clinical Indication entered for "_$P($G(^LAB(60,TST,0)),U),!! Q ; IHS/MSC/MKK - LR*5.2*1034
S STUFF=Y
ASK2 K DIR
S DIR(0)="Y"
S DIR("B")="YES"
S DIR("A")="Is this correct"
D ^DIR
G:'Y ASK1B
Q
;
;ENTER DIAGNOSIS FOR JUST ONE TEST
ADDTST(LRODT,ORDIEN,TST) ;EP CALLED FROM LRTSTSET WHEN ADDING TEST TO ORDER
Q:$G(LRODT)=""!($G(ORDIEN)="")!($G(TST)="")
;
Q:$$CHKORDAC^BLRSGNSU(LRODT,ORDIEN,TST) ; IHS/MSC/MKK - LR*5.2*1033
;
NEW BAILOUT
;
S DA=$O(^LRO(69,LRODT,1,ORDIEN,2,"B",TST,""))
S DIE="^LRO(69,"_LRODT_",1,"_ORDIEN_",2,"
; D ASK1(.STUFF,TST,,ORDIEN,DA)
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
S:+$G(LRORD)<1 LRORD=+$G(^LRO(69,LRODT,1,ORDIEN,.1))
S ^TMP("BLRDIAG",$J,"ORDER")=LRORD
S ^TMP("BLRDIAG",$J,"ORDER","ADDTST")=DA
S X=$$GETSDIAG^BLRSGNSY(DFN,LRORD,LRODT,ORDIEN,DA,.BAILOUT)
K ^TMP("BLRDIAG",$J,"ORDER")
K:+$G(BAILOUT) LRFLG Q
; ----- END IHS/MSC/MKK - LR*5.2*1033
;
Q:$G(Y)[U&($G(XQY0)["LRADD TO ORDER") ;IF TRUE THEN ORDER CANCELED
;
I $G(Y)[U,($G(XQY0)["LRADD TO ACC") D DELACC Q
S DR="9999999.1///^S X=STUFF"
L +^LRO(69,LRODT,1,ORDIEN):1 I '$T W !,"ORDER IS CURRENTLY BEING EDITED!" Q
D ^DIE ; IHS/MSC/MKK - LR*5.2*1033 -- routine BLRSGNSY adds Diag to File 69
L -^LRO(69,LRODT,1,ORDIEN)
Q
;
;CANCEL ENTIRE ORDER
CANORD(LRODT,LRORD) ;EP
S LRSNTMP="" F S LRSNTMP=$O(^LRO(69,"C",LRORD,LRODT,LRSNTMP)) Q:LRSNTMP="" D
.S TT=0 F S TT=$O(^LRO(69,LRODT,1,LRSNTMP,2,TT)) Q:TT<1 K TST S X=^(TT,0) I '$P(X,"^",11) I 'LRNOP D
..S X=^LRO(69,LRODT,1,LRSNTMP,2,TT,0) W !,?5,$P(^LAB(60,+X,0),"^")
..S $P(^LRO(69,LRODT,1,LRSNTMP,2,TT,0),"^",3,6)="^^^",$P(^(0),"^",9,11)="CA^L^"_DUZ
..; S DIE="^LRO(69,LRODT,1,LRSNTMP,2,",DA=TT,DA(1)=LRSN,DA(2)=LRODT,DR=99 D ^DIE ;NO NEED TO ENTER COMMENTS?
S LRNCWL=1 ;SET TO BYPASS PRINTING ORDER COPY
;S LRPHSET=1 ;
K LRSNTMP
Q
;
;CANCEL TEST
CANTST(LRSN,TT) ;EP
S LRACC=0
K TST
S X=^LRO(69,LRODT,1,LRSN,2,TT,0)
I '$P(X,"^",11) S TST(+X)="",LRAD=+$P(X,U,3),LRAA=+$P(X,U,4),LRAN=+$P(X,U,5),ORIFN=$P(X,U,7) I 'LRNOP D
.S X=^LRO(69,LRODT,1,LRSN,2,TT,0) W !,?5,$P(^LAB(60,+X,0),"^")
.S $P(^LRO(69,LRODT,1,LRSN,2,TT,0),"^",3,6)="^^^",$P(^(0),"^",9,11)="CA^L^"_DUZ
.;S DIE="^LRO(69,LRODT,1,LRSN,2,",DA=TT,DA(1)=LRSN,DA(2)=LRODT,DR=99 D ^DIE ;NO NEED TO ENTER COMMENTS?
;S LRNCWL=1 ;SET TO BYPASS PRINTING ORDER COPY
;S LRPHSET=1
Q
;
;DELETE ACCESSION
;THIS IS CALLED WHEN THEN OPTION ADD A TEST TO AN ACCESSION IS USED
;AND THE USER USES THE "^" TO GET OUT OF THE 'SIGN OR SYMPTOM' PROMPT
;IF THIS IS NOT DONE THE USER CAN THEN RESULT THE TEST WITHOUT HAVING
;TO ENTER A POV
DELACC ;
S LRTSTS=LRTS
S LRTNM=$P($G(^LAB(60,LRTS,0)),U)
;S LRCCOM="UP ARROWED OUT OF 'SIGN OR SYMPTOM' PROMPT"
S LRCCOM="CANCELLED NO POV ENTERED"
I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,3)) S LRIDT=$P(^(3),U,5)
S X=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LROWDT=$P(X,U,3),LRODT=$P(X,U,4),LRSN=$P(X,U,5) I LROWDT=LRAD S:$D(^LRO(68,LRAA,1,LRAD,1,LRAN,9)) LROWDT=^(9)
D TESTDEL^BLRDIAG1
; W !!,"Press Return to continue..." R X:DTIME
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
W !!
D ^XBFMK
S DIR(0)="FAO"
S DIR("A")="Press Return to continue..."
S DIR("T")=15
D ^DIR
; ----- END IHS/MSC/MKK - LR*5.2*1031
;
K LRFLG
;
Q
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
ASKLPOV(PROMPT) ; EP - Ask Lab Purpose Of Visit. Must be answered.
NEW ANSWER,BADINPUT,DA,DIE
;
S BADINPUT=1
F Q:+$G(BADINPUT)<1 D
. D ^XBFMK
. K DIR
. S DIR("A",1)=PROMPT
. S DIR("A")="(DO NOT USE 'RULE OUT', 'PROBABLE', 'QUESTIONABLE', etc.)"
. S DIR(0)="69.03,9999999.1^^"_$P(^DD(69.03,9999999.1,0),U,5)
. W !
. D ^DIR
. S BADINPUT=0
. S ANSWER=$$UP^XLFSTR($P(Y,"^"))
. I +$G(DIRUT)>0!(ANSWER["RULE OUT")!(ANSWER["PROBABLE")!(ANSWER["QUESTIONABLE") D
.. W !,?4,"Invalid/'^' input not allowed."
.. D PRESSKEY^BLRGMENU(9)
.. S BADINPUT=1
Q
; ----- END IHS/MSC/MKK - LR*5.2*1031
BLRDIAG ;IHS/ITSC/TPF - MAIN 'SIGN OR SYMPTOM' LAB POV INPUT ROUTINE; 22-Oct-2013 09:22 ; MKK
+1 ;;5.2;IHS LABORATORY;**1015,1017,1018,1019,1021,1027,1031,1033,1034**;NOV 01, 1997;Build 88
+2 ;
+3 ;NOTE: LRPOVREQ WAS USED AS A SITE PARAMETER DURING DEVELOPMENT.
+4 ;IT WAS THOUGHT THAT THIS REQUIREMENT WOULD BE DECIDED UPON BY EACH
+5 ;SITE. HOWEVER MED REC HAS DECIDED SINCE THIS IS REQUIRED BY LAW IT
+6 ;SHOULD NOT BE LEFT TO EACH SITE'S CHOICE TO REQUIRE THE FIELD OR
+7 ;NOT. THE VARIABLE HAS BEEN LEFT IN FOR ALPHA TESTING
+8 QUIT
UPPER(X) ; EP
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 ;
+3 ;AFTER THE ENTIRE ORDER IS COMPLETE LETS DO THE 'SIGN OR SYMPTOM'
+4 ;ALSO IF NEED BE CHECK TO SEE IF WE NEED TO ACCESSION THEM AS WELL (FAST E.G.)
COMPORD(LRODT,LRORD) ;EP CALLED FROM LRORDST
+1 ;
+2 IF $GET(LRODT)=""!($GET(LRORD)="")
QUIT
+3 ;
+4 ;
+5 NEW TMPCWL,TMPSET
+6 ;IHS/ITSC/TPF ALLOW ENTRY OF 'SIGN OR SYMPTOM' LAB POV **1015*
DO DIAG(LRODT,LRORD)
+7 ;
+8 IF LRORDR=""
Begin DoDot:1
+9 SET ORDIEN=""
FOR
SET ORDIEN=$ORDER(^LRO(69,"C",LRORD,LRODT,ORDIEN))
IF ORDIEN=""
QUIT
Begin DoDot:2
+10 ;S LRSN=ORDIEN S LRPHSET=0 D ^LRWLST K LRPHSET
+11 ;KILL LRNCWL TO MAKE SURE THE PROMPT TO ALLOW USER TO ENTER AN
+12 ;NUMBER IS NOT DISPLAYED AT WL2+1^LRWLST
+13 ;KILL LRPHSET TO MAKE SURE THE ACCESSION IS DISPLAYED AT
+14 ;STWLN+8^LRWLST1
+15 ;KILL LRNCWL TO MAKE SURE PROMPT FOR ENTRY # IS NOT ASKED
+16 SET LRSN=ORDIEN
IF $DATA(LRNCWL)
SET TMPCWL=$GET(LRNCWL)
IF $DATA(LRPHSET)
SET TMPSET=LRPHSET
KILL LRNCWL,LRPHSET
DO ^LRWLST
IF $DATA(TMPCWL)
SET LRNCWL=TMPCWL
IF $DATA(TMPSET)
SET LRPHSET=TMPSET
End DoDot:2
End DoDot:1
+17 ;
+18 QUIT
+19 ;
DIAG(LRODT,LRORD) ;EP CALLED FROM LROW2A,LRTSTSET
+1 DO ENTRYAUD^BLRUTIL("DIAG^BLRDIAG 0.0")
+2 ;
+3 IF $GET(LRODT)=""!($GET(LRORD)="")
QUIT
+4 ;
+5 DO ENTRYAUD^BLRUTIL("DIAG^BLRDIAG 1.0")
+6 ;
+7 ;DO WE HAVE MULTIPLE ENTRIES WE NEED TO ADD THE DIAG TO?
+8 SET MULTIPL=0
+9 DO MULTTST(LRORD,LRODT,.MULTIPL)
+10 ;
+11 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1019 -- Patient Chart Mod
+12 IF $GET(BLRGUI)
GOTO RPT
+13 ;----- END IHS MODIFICATIONS LR*5.2*1019 -- Patient Chart Mod
+14 ;
+15 ;IHS/ITSC/TPF 'SIGN OR SYMPTOM' LABPOV **1015**
+16 DO ENTRYAUD^BLRUTIL("DIAG^BLRDIAG 2.0")
+17 ;
+18 WRITE !!
+19 ;IHS/ITSC/TPF ASSUME USER WANTS SAME DIAG FOR ALL TESTS
SET ASKALL=0
+20 IF MULTIPL
Begin DoDot:1
+21 ;----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1021 -- Yes or No ONLY
YNONLY ;
+1 ;----- END IHS/OIT/MKK MODIFICATION LR*5.2*1021
+2 KILL STUFF
+3 KILL DIR
+4 ; S DIR("A")="Do you want to enter a different Sign or Symptom for each test?"
+5 ; IHS/MSC/MKK - LR*5.2*1034
SET DIR("A")="Do you want to enter a different Clinical Indication for each test?"
+6 SET DIR("B")="N"
+7 SET DIR(0)="Y"
+8 DO ^DIR
+9 ;----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1021 -- Yes or No ONLY
+10 ; Only "Y" or "N" allowed
IF X'="Y"&(X'="N")
GOTO YNONLY
+11 ;----- END IHS/OIT/MKK MODIFICATION LR*5.2*1021
+12 SET ASKALL=Y
End DoDot:1
IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+13 ;
+14 ;cmi/anch/maw 5/22/2008 for reference lab
IF ASKALL
SET BLRRLASK=1
+15 IF ASKALL
DO ASK(LRORD,LRODT,1,.MULTIPL)
WRITE !!
QUIT
+16 ;
+17 ;EXECUTION FALLS TO HERE IF A "BLANKET" DIAGNOSIS IS TO BE ENTERED
+18 ;FOR THE ENTIRE ORDER
RPT ;
+1 SET LRPOVREQ=1
+2 KILL DIR,STUFF
+3 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1019 -- Patient Chart Mod
+4 IF $GET(BLRGUI)
IF BPCCOM=""
QUIT
DO ASK(LRORD,LRODT,0,.MULTIPL,BPCCOM)
QUIT
+5 ;----- END IHS MODIFICATIONS LR*5.2*1019 -- Patient Chart Mod
+6 ;
+7 ; S DIR("A",1)="Enter Sign or Symptom for LAB Order number "_LRORD
+8 ; S DIR("A")="(DO NOT USE 'RULE OUT', 'PROBABLE', 'QUESTIONABLE', etc.)"
+9 ; S DIR(0)="69.03,9999999.1^^"_$P(^DD(69.03,9999999.1,0),U,5)
+10 ; W !
+11 ; D ^DIR
+12 ;
+13 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
+14 ; D ASKLPOV("Enter Sign or Symptom for LAB Order number "_LRORD)
+15 ; ----- END IHS/MSC/MKK - LR*5.2*1031
+16 ;
+17 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
+18 SET ^TMP("BLRDIAG",$JOB,"ORDER")=LRORD
+19 SET ^TMP("BLRDIAG",$JOB,"ORDER","ALLTESTS")="YES"
+20 SET X=$$ALLTESTS^BLRSGNSY(DFN,LRORD,LRODT)
+21 IF X
DO GETRID^BLRSGNSP(LRORD)
+22 QUIT
+23 ; ----- END IHS/MSC/MKK - LR*5.2*1033
+24 ;
+25 ;ADDED 12/30/02
IF Y[U
SET LRNOP=0
DO CANORD(LRODT,LRORD)
WRITE !!,"ORDER CANCELED!!"
QUIT
+26 IF $GET(LRPOVREQ)
IF ($DATA(DUOUT)!$DATA(DTOUT)!(Y=""))
WRITE !,"This is a required response."
GOTO RPT
+27 ; I Y=""!(Y[U) W !!,"No Sign or Symptom entered for order number "_LRORD,!! Q
+28 ; IHS/MSC/MKK - LR*5.2*1034
IF Y=""!(Y[U)
WRITE !!,"No Clinical Indication entered for order number "_LRORD,!!
QUIT
+29 SET STUFF=Y
+30 KILL DIR
+31 SET DIR(0)="Y"
+32 SET DIR("B")="YES"
+33 SET DIR("A")="Is this correct"
+34 DO ^DIR
+35 IF 'Y
GOTO RPT
+36 ;
+37 DO ASK(LRORD,LRODT,0,.MULTIPL,STUFF)
+38 WRITE !!
+39 QUIT
+40 ;
+41 ;DO WE HAVE MULTIPLE TESTS FOR THIS ORDER?
MULTTST(LRORD,LRODT,MULTIPL) ;
+1 SET ^TMP("BLRDIAG",$JOB,"ORDER")=LRORD
+2 ;
+3 SET ORDIEN=""
FOR I=1:1
SET ORDIEN=$ORDER(^LRO(69,"C",LRORD,LRODT,ORDIEN))
IF ORDIEN=""
QUIT
Begin DoDot:1
+4 IF I>1
SET MULTIPL=1
QUIT
+5 SET TST=""
FOR J=1:1
SET TST=$ORDER(^LRO(69,LRODT,1,ORDIEN,2,"B",TST))
IF TST=""
QUIT
Begin DoDot:2
+6 IF J>1
SET MULTIPL=1
QUIT
End DoDot:2
IF MULTIPL
QUIT
End DoDot:1
IF MULTIPL
QUIT
+7 QUIT
+8 ;
+9 ;GO THROUGH ORDER D FOR EACH TEST AND PROMPT IF ASKING AND STUFF IF NOT
ASK(LRORD,LRODT,ASK,MULTIPL,STUFF) ; EP
+1 DO ENTRYAUD^BLRUTIL("ASK^BLRDIAG 0.0")
+2 ;
+3 NEW I,J,ORDIEN,TST,SEQ,Y,DFNFLAG
+4 ; IHS/MSC/MKK - LR*5.2*1033
NEW BAILOUT
+5 ;
+6 IF +$GET(DFN)<1
Begin DoDot:1
+7 SET LRSP=$ORDER(^LRO(69,"C",LRORD,LRODT,0))
+8 SET LRDFN=+$GET(^LRO(69,LRODT,1,LRSP,0))
+9 SET DFN=+$PIECE($GET(^LR(LRDFN,0)),"^",3)
+10 SET DFNFLAG=1
End DoDot:1
+11 ;
+12 ; IHS/MSC/MKK - LR*5.2*1033
SET ^TMP("BLRDIAG",$JOB,"ORDER")=LRORD
+13 ; IHS/MSC/MKK - LR*5.2*1033
SET BAILOUT=0
+14 SET STUFF=$$UPPER($GET(STUFF))
+15 ; S ORDIEN="" F I=1:1 S ORDIEN=$O(^LRO(69,"C",LRORD,LRODT,ORDIEN)) Q:ORDIEN="" D
+16 ; S ORDIEN="" F S ORDIEN=$O(^LRO(69,"C",LRORD,LRODT,ORDIEN)) Q:ORDIEN="" D ; IHS/OIT/MKK - LR*5.2*1031
+17 ; IHS/MSC/MKK - LR*5.2*1033
SET ORDIEN=""
FOR
SET ORDIEN=$ORDER(^LRO(69,"C",LRORD,LRODT,ORDIEN))
IF ORDIEN=""!(BAILOUT)
QUIT
Begin DoDot:1
+18 ; S TST="" F J=1:1 S TST=$O(^LRO(69,LRODT,1,ORDIEN,2,"B",TST)) Q:TST="" D
+19 ; S TST="" F S TST=$O(^LRO(69,LRODT,1,ORDIEN,2,"B",TST)) Q:TST="" D ; IHS/OIT/MKK - LR*5.2*1031
+20 ; IHS/MSC/MKK - LR*5.2*1033
SET TST=0
FOR
SET TST=$ORDER(^LRO(69,LRODT,1,ORDIEN,2,TST))
IF TST<1!(BAILOUT)
QUIT
Begin DoDot:2
+21 ;
+22 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
+23 WRITE !!,?4,"SIGN/SYMPTOM FOR TEST: ",$$GET1^DIQ(69.03,TST_","_ORDIEN_","_LRODT_",","TEST/PROCEDURE")
+24 SET BAILOUT=$$GETSDIAG^BLRSGNSY(DFN,LRORD,LRODT,ORDIEN,TST)
+25 QUIT
+26 ; ----- END IHS/MSC/MKK - LR*5.2*1033
+27 ;
+28 SET DA=$ORDER(^LRO(69,LRODT,1,ORDIEN,2,"B",TST,""))
+29 SET DIE="^LRO(69,"_LRODT_",1,"_ORDIEN_",2,"
+30 IF ASK
Begin DoDot:3
+31 SET DEF=$GET(^LRO(69,LRODT,1,ORDIEN,2,DA,9999999))
+32 DO ASK1(.STUFF,TST,DEF,ORDIEN,DA)
+33 ;IF TRUE TEST HAS BEEN CANCELLED
IF $GET(Y)[U
QUIT
+34 SET DR="9999999.1///^S X=STUFF"
+35 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1019 -- Patient Chart Mod
+36 ; L +^LRO(69,LRODT,1,ORDIEN):1 I '$T W !,"ORDER IS CURRENTLY BEING EDITED!" Q
+37 LOCK +^LRO(69,LRODT,1,ORDIEN):1
IF '$TEST
IF '$GET(BLRGUI)
WRITE !,"ORDER IS CURRENTLY BEING EDITED!"
IF $GET(BLRGUI)
SET RESULT(1)=-1
SET RESULT(2)="ORDER IS CURRENTLY BEING EDITED!"
QUIT
+38 ;----- END IHS MODIFICATIONS LR*5.2*1019 -- Patient Chart Mod
+39 DO ^DIE
LOCK -^LRO(69,LRODT,1,ORDIEN)
End DoDot:3
QUIT
+40 IF 'ASK
IF ($GET(STUFF)'="")
SET DR="9999999.1///^S X=STUFF"
Begin DoDot:3
+41 LOCK +^LRO(69,LRODT,1,ORDIEN):1
IF '$TEST
WRITE !,"ORDER IS CURRENTLY BEING EDITED!"
QUIT
+42 DO ^DIE
LOCK -^LRO(69,LRODT,1,ORDIEN)
End DoDot:3
End DoDot:2
End DoDot:1
+43 ;
+44 IF +$GET(DFNFLAG)
KILL LRDFN,DFN,LRSP
+45 KILL I,J,ORDIEN,TST
+46 ; IHS/MSC/MKK - LR*5.2*1033
KILL ^TMP("BLRDIAG",$JOB,"ORDER")
+47 QUIT
+48 ;
+49 ;PROMPT FOR 'SIGN OR SYMPTOM'
ASK1(STUFF,TST,DEF,ORDIEN,DA) ;
+1 SET LRPOVREQ=1
ASK1B KILL DIR
+1 SET STUFF=$$UPPER($GET(STUFF))
+2 ; S DIR("B")=$G(DEF)
+3 ; S DIR("A",1)="Enter Sign or Symptom for "_$P($G(^LAB(60,TST,0)),U)
+4 ; S DIR("A")="(DO NOT USE 'RULE OUT', 'PROBABLE', 'QUESTIONABLE', etc.)"
+5 ; S DIR(0)="69.03,9999999.1^^"_$P(^DD(69.03,9999999.1,0),U,5)
+6 ; W !
+7 ; D ^DIR
+8 ;
+9 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
+10 ; D ASKLPOV("Enter Sign or Symptom for "_$P($G(^LAB(60,TST,0)),U))
+11 ; IHS/MSC/MKK - LR*5.2*1034
DO ASKLPOV("Enter Clinical Indication for "_$PIECE($GET(^LAB(60,TST,0)),U))
+12 ; ----- END IHS/MSC/MKK - LR*5.2*1031
+13 ;
+14 ;I Y[U S LRNOP=0 D CANTST(ORDIEN,$S($G(DA)'="":DA,1:LRTN)) W !!,"TEST CANCELED FROM ORDER!!" Q ;ADDED 12/30/02
+15 ;IHS/ITSC/TPF 7/1/03 **1017**
IF Y[U
SET LRNOP=0
DO CANTST(ORDIEN,$SELECT($GET(DA)'="":DA,$DATA(LRSN):LRSN,1:LRTN))
WRITE !!,"TEST CANCELED FROM ORDER!!"
QUIT
+16 IF $GET(LRPOVREQ)
IF ($DATA(DUOUT)!$DATA(DTOUT)!(Y=""))
WRITE !,"This is a required response."
GOTO ASK1B
+17 ; I Y=""!(Y[U) W !!,"No Sign or Symptom entered for "_$P($G(^LAB(60,TST,0)),U),!! Q
+18 ; IHS/MSC/MKK - LR*5.2*1034
IF Y=""!(Y[U)
WRITE !!,"No Clinical Indication entered for "_$PIECE($GET(^LAB(60,TST,0)),U),!!
QUIT
+19 SET STUFF=Y
ASK2 KILL DIR
+1 SET DIR(0)="Y"
+2 SET DIR("B")="YES"
+3 SET DIR("A")="Is this correct"
+4 DO ^DIR
+5 IF 'Y
GOTO ASK1B
+6 QUIT
+7 ;
+8 ;ENTER DIAGNOSIS FOR JUST ONE TEST
ADDTST(LRODT,ORDIEN,TST) ;EP CALLED FROM LRTSTSET WHEN ADDING TEST TO ORDER
+1 IF $GET(LRODT)=""!($GET(ORDIEN)="")!($GET(TST)="")
QUIT
+2 ;
+3 ; IHS/MSC/MKK - LR*5.2*1033
IF $$CHKORDAC^BLRSGNSU(LRODT,ORDIEN,TST)
QUIT
+4 ;
+5 NEW BAILOUT
+6 ;
+7 SET DA=$ORDER(^LRO(69,LRODT,1,ORDIEN,2,"B",TST,""))
+8 SET DIE="^LRO(69,"_LRODT_",1,"_ORDIEN_",2,"
+9 ; D ASK1(.STUFF,TST,,ORDIEN,DA)
+10 ;
+11 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
+12 IF +$GET(LRORD)<1
SET LRORD=+$GET(^LRO(69,LRODT,1,ORDIEN,.1))
+13 SET ^TMP("BLRDIAG",$JOB,"ORDER")=LRORD
+14 SET ^TMP("BLRDIAG",$JOB,"ORDER","ADDTST")=DA
+15 SET X=$$GETSDIAG^BLRSGNSY(DFN,LRORD,LRODT,ORDIEN,DA,.BAILOUT)
+16 KILL ^TMP("BLRDIAG",$JOB,"ORDER")
+17 IF +$GET(BAILOUT)
KILL LRFLG
QUIT
+18 ; ----- END IHS/MSC/MKK - LR*5.2*1033
+19 ;
+20 ;IF TRUE THEN ORDER CANCELED
IF $GET(Y)[U&($GET(XQY0)["LRADD TO ORDER")
QUIT
+21 ;
+22 IF $GET(Y)[U
IF ($GET(XQY0)["LRADD TO ACC")
DO DELACC
QUIT
+23 SET DR="9999999.1///^S X=STUFF"
+24 LOCK +^LRO(69,LRODT,1,ORDIEN):1
IF '$TEST
WRITE !,"ORDER IS CURRENTLY BEING EDITED!"
QUIT
+25 ; IHS/MSC/MKK - LR*5.2*1033 -- routine BLRSGNSY adds Diag to File 69
DO ^DIE
+26 LOCK -^LRO(69,LRODT,1,ORDIEN)
+27 QUIT
+28 ;
+29 ;CANCEL ENTIRE ORDER
CANORD(LRODT,LRORD) ;EP
+1 SET LRSNTMP=""
FOR
SET LRSNTMP=$ORDER(^LRO(69,"C",LRORD,LRODT,LRSNTMP))
IF LRSNTMP=""
QUIT
Begin DoDot:1
+2 SET TT=0
FOR
SET TT=$ORDER(^LRO(69,LRODT,1,LRSNTMP,2,TT))
IF TT<1
QUIT
KILL TST
SET X=^(TT,0)
IF '$PIECE(X,"^",11)
IF 'LRNOP
Begin DoDot:2
+3 SET X=^LRO(69,LRODT,1,LRSNTMP,2,TT,0)
WRITE !,?5,$PIECE(^LAB(60,+X,0),"^")
+4 SET $PIECE(^LRO(69,LRODT,1,LRSNTMP,2,TT,0),"^",3,6)="^^^"
SET $PIECE(^(0),"^",9,11)="CA^L^"_DUZ
+5 ; S DIE="^LRO(69,LRODT,1,LRSNTMP,2,",DA=TT,DA(1)=LRSN,DA(2)=LRODT,DR=99 D ^DIE ;NO NEED TO ENTER COMMENTS?
End DoDot:2
End DoDot:1
+6 ;SET TO BYPASS PRINTING ORDER COPY
SET LRNCWL=1
+7 ;S LRPHSET=1 ;
+8 KILL LRSNTMP
+9 QUIT
+10 ;
+11 ;CANCEL TEST
CANTST(LRSN,TT) ;EP
+1 SET LRACC=0
+2 KILL TST
+3 SET X=^LRO(69,LRODT,1,LRSN,2,TT,0)
+4 IF '$PIECE(X,"^",11)
SET TST(+X)=""
SET LRAD=+$PIECE(X,U,3)
SET LRAA=+$PIECE(X,U,4)
SET LRAN=+$PIECE(X,U,5)
SET ORIFN=$PIECE(X,U,7)
IF 'LRNOP
Begin DoDot:1
+5 SET X=^LRO(69,LRODT,1,LRSN,2,TT,0)
WRITE !,?5,$PIECE(^LAB(60,+X,0),"^")
+6 SET $PIECE(^LRO(69,LRODT,1,LRSN,2,TT,0),"^",3,6)="^^^"
SET $PIECE(^(0),"^",9,11)="CA^L^"_DUZ
+7 ;S DIE="^LRO(69,LRODT,1,LRSN,2,",DA=TT,DA(1)=LRSN,DA(2)=LRODT,DR=99 D ^DIE ;NO NEED TO ENTER COMMENTS?
End DoDot:1
+8 ;S LRNCWL=1 ;SET TO BYPASS PRINTING ORDER COPY
+9 ;S LRPHSET=1
+10 QUIT
+11 ;
+12 ;DELETE ACCESSION
+13 ;THIS IS CALLED WHEN THEN OPTION ADD A TEST TO AN ACCESSION IS USED
+14 ;AND THE USER USES THE "^" TO GET OUT OF THE 'SIGN OR SYMPTOM' PROMPT
+15 ;IF THIS IS NOT DONE THE USER CAN THEN RESULT THE TEST WITHOUT HAVING
+16 ;TO ENTER A POV
DELACC ;
+1 SET LRTSTS=LRTS
+2 SET LRTNM=$PIECE($GET(^LAB(60,LRTS,0)),U)
+3 ;S LRCCOM="UP ARROWED OUT OF 'SIGN OR SYMPTOM' PROMPT"
+4 SET LRCCOM="CANCELLED NO POV ENTERED"
+5 IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
SET LRIDT=$PIECE(^(3),U,5)
+6 SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,0)
SET LROWDT=$PIECE(X,U,3)
SET LRODT=$PIECE(X,U,4)
SET LRSN=$PIECE(X,U,5)
IF LROWDT=LRAD
IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,9))
SET LROWDT=^(9)
+7 DO TESTDEL^BLRDIAG1
+8 ; W !!,"Press Return to continue..." R X:DTIME
+9 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
+10 WRITE !!
+11 DO ^XBFMK
+12 SET DIR(0)="FAO"
+13 SET DIR("A")="Press Return to continue..."
+14 SET DIR("T")=15
+15 DO ^DIR
+16 ; ----- END IHS/MSC/MKK - LR*5.2*1031
+17 ;
+18 KILL LRFLG
+19 ;
+20 QUIT
+21 ;
+22 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
ASKLPOV(PROMPT) ; EP - Ask Lab Purpose Of Visit. Must be answered.
+1 NEW ANSWER,BADINPUT,DA,DIE
+2 ;
+3 SET BADINPUT=1
+4 FOR
IF +$GET(BADINPUT)<1
QUIT
Begin DoDot:1
+5 DO ^XBFMK
+6 KILL DIR
+7 SET DIR("A",1)=PROMPT
+8 SET DIR("A")="(DO NOT USE 'RULE OUT', 'PROBABLE', 'QUESTIONABLE', etc.)"
+9 SET DIR(0)="69.03,9999999.1^^"_$PIECE(^DD(69.03,9999999.1,0),U,5)
+10 WRITE !
+11 DO ^DIR
+12 SET BADINPUT=0
+13 SET ANSWER=$$UP^XLFSTR($PIECE(Y,"^"))
+14 IF +$GET(DIRUT)>0!(ANSWER["RULE OUT")!(ANSWER["PROBABLE")!(ANSWER["QUESTIONABLE")
Begin DoDot:2
+15 WRITE !,?4,"Invalid/'^' input not allowed."
+16 DO PRESSKEY^BLRGMENU(9)
+17 SET BADINPUT=1
End DoDot:2
End DoDot:1
+18 QUIT
+19 ; ----- END IHS/MSC/MKK - LR*5.2*1031
