ORCDRA ; SLC/MKB - Utility functions for RA dialogs ;7/23/01 11:47
;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,53,95,141**;Dec 17, 1997
;
EN ; -- Entry action for RA OERR EXAM order dialog
D LAST7:$G(ORTAB)="ORDERS"
ENA N ENT D ITYPE ;enter here for Quick Setup (editor) instead
S ENT="ALL"_$S($G(ORDIV):"^DIV.`"_ORDIV,1:"")
S ORBROAD=$$GET^XPAR(ENT,"RA REQUIRE DETAILED",1,"Q")
Q
;
EX ; -- Exit action for RA OERR EXAM order dialog
K ORBROAD,ORIMTYPE,ORIMLOC,ORMORE,ORDIV
Q
;
LAST7 ; -- Display last 7 days of exams for patient
N IDT,EXDT,EXAM,STS,Y
Q:$G(ORTYPE)="Q" Q:$G(ORACT)="XX" Q:$G(ORACT)="RN"
K ^TMP($J,"RAE7") D EN2^RAO7PC1(+ORVP)
Q:'$O(^TMP($J,"RAE7",+ORVP,0)) S IDT=0 ; no exams
W !!,"Case # Exams Over the Last 7 Days Exam Date Status of Exam Imaging Loc.",!,"------ -------------------------- --------- -------------- ------------"
F S IDT=$O(^TMP($J,"RAE7",+ORVP,IDT)) Q:IDT'>0 S EXAM=$G(^(IDT)) D
. S Y=$P(9999999-$P(IDT,"-"),".") X ^DD("DD")
. S STS=$P(EXAM,U,3),STS=$S(STS="V":"VERIFIED",STS="R":"RELEASED/UNVER",STS="N":"NO REPORT",STS="P":"PARTIAL",1:"")
. W !,$E($P(EXAM,U,2),1,9),?10,$E($P(EXAM,U),1,28),?39,Y_" "_STS,?67,$E($P(EXAM,U,5),1,12)
K ^TMP($J,"RAE7") W !
Q
;
ITYPE ; -- Select Imaging Type for ordering, sets ORIMTYPE
N XRAY,DA,DG,DG0,ABBREV,CNT,ITYPE,DIC,X,Y,I,NAME,OI,IFN,ORY
I $G(ORTYPE)="Q" S ORDG=ORDG_U_$G(^ORD(100.98,+ORDG,0)) G ITQ
I $G(ORIFN) S DG=+$P(^OR(100,+ORIFN,0),U,11),ORDG=DG_U_$G(^ORD(100.98,DG,0)) G ITQ ; edit
S XRAY=$O(^ORD(100.98,"B","XRAY",0)),(DA,CNT)=0
I $G(ORTYPE)="Z",ORDG'=XRAY S ORDG=ORDG_U_$G(^ORD(100.98,+ORDG,0)) G ITQ
F S DA=$O(^ORD(100.98,XRAY,1,DA)) Q:DA'>0 S DG=$G(^(DA,0)) D
. S DG0=$G(^ORD(100.98,DG,0)),ABBREV=$P(DG0,U,3)
. ;I $D(^ORD(101.43,"S."_ABBREV)) S CNT=CNT+1,ITYPE(ABBREV)=DG_U_DG0
. I $$ACTIVE(ABBREV) S CNT=CNT+1,ITYPE(ABBREV)=DG_U_DG0
I 'CNT W $C(7),!!,"No active Imaging Types defined!",! H 3 S ORQUIT=1 Q
I CNT=1 S I=$O(ITYPE("")),ORDG=ITYPE(I) G ITQ
W !!,"Select one of the following imaging types:"
S I="" F S I=$O(ITYPE(I)) Q:I="" W !," "_$P(ITYPE(I),U,2)
S DIC="^RA(79.2,",DIC(0)="AEQMZ",DIC("A")="Select IMAGING TYPE: "
S DIC("S")="I $D(ITYPE($P(^(0),U,3)))" W !
D ^DIC I $D(DTOUT)!$D(DUOUT)!(Y<0) S ORQUIT=1 Q
S ORDG=ITYPE($P(Y(0),U,3))
ITQ S NAME=$P(ORDG,U,3),OI=$$PTR^ORCD("OR GTX ORDERABLE ITEM")
S ORDIALOG(OI,"A")=NAME_" Procedure: ",ORDIALOG(OI,"?")="Enter the "_NAME_" procedure to be ordered for this patient"
S ITYPE=$P(ORDG,U,4),ORIMTYPE=$O(^RA(79.2,"C",ITYPE,0))
S ORDIALOG(OI,"D")="S."_ITYPE_";C."_ITYPE
I ORIMTYPE D ; screen modifiers on ImType
. N PTR S PTR=$$PTR^ORCD("OR GTX MODIFIERS") Q:'PTR
. S ORDIALOG(PTR,"S")="I $D(^RAMIS(71.2,""AB"","_ORIMTYPE_",+Y))"
S ORDIV=$$DIV^ORCDRA1 D EN4^RAO7PC1(ITYPE,"ORY")
S (IFN,CNT)=0 F S IFN=$O(ORY(IFN)) Q:IFN'>0 S CNT=CNT+1,ORIMLOC(CNT)=ORY(IFN),ORIMLOC("B",$P(ORY(IFN),U,2))=IFN ; I $P(ORY(IFN),U,3)=ORDIV
I '$$GET^XPAR("ALL^DIV.`"_ORDIV,"RA SUBMIT PROMPT",1,"Q"),CNT>1 K ORIMLOC ; don't present any choices
E S ORIMLOC=CNT_"^1"
Q
;
ACTIVE(DG) ; -- Returns 1 or 0, if active OI's exist for DG
N X,Y,IDX,ROOT,NOW S Y=0
G:'$L($G(DG)) ACTQ G:'$D(^ORD(101.43,"S."_DG)) ACTQ
S IDX="^ORD(101.43,""S."_DG_""")",ROOT=$TR(IDX,")",","),NOW=$$NOW^XLFDT
F S IDX=$Q(@IDX) Q:$E(IDX,1,$L(ROOT))'=ROOT S X=$P(@IDX,U,3) I 'X!(X>NOW) S Y=1 Q ;at least one active orderable in index
ACTQ Q Y
;
COMMON ; -- Build ORDIALOG(PROMPT,"LIST") of Common Procedures
N CNT,ITYPE,NAME,DA K ORDIALOG(PROMPT,"LIST")
S:'$D(ORDG) ORDG=$P(^ORD(101.41,+ORDIALOG,0),U,5),ORDG=ORDG_U_$G(^ORD(100.98,+ORDG,0))
S ITYPE=$P(^ORD(100.98,+ORDG,0),U,3) Q:'$D(^ORD(101.43,"COMMON",ITYPE))
S NAME="",CNT=0
F S NAME=$O(^ORD(101.43,"COMMON",ITYPE,NAME)) Q:NAME="" S DA=$O(^(NAME,0)),CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=DA_U_NAME
S ORDIALOG(PROMPT,"LIST")=CNT
S:CNT $P(ORDIALOG(PROMPT,"?"),";",2)=" select either the number of a common procedure listed above or the name of any "_$$LOW^XLFSTR($P(ORDG,U,2))_" procedure"
Q
;
LIST ; -- List Common Procedures in ORDIALOG(PROMPT,"LIST") for selection
N NUM,DA,HALF,DIR,Y Q:'$O(ORDIALOG(PROMPT,"LIST",0))
S HALF=ORDIALOG(PROMPT,"LIST")\2
I ORDIALOG(PROMPT,"LIST")\2*2'=ORDIALOG(PROMPT,"LIST") S HALF=HALF+1
W !!,"Common "_$$LOWER^VALM1($P(ORDG,U,2))_" Procedures: "
S Y=1 F NUM=1:1:HALF D Q:'+Y
. S DA=ORDIALOG(PROMPT,"LIST",NUM)
. W !,$J(NUM,3)_" "_$E($P(ORDIALOG(PROMPT,"LIST",NUM),U,2),1,36)
. S DA=$G(ORDIALOG(PROMPT,"LIST",NUM+HALF)) Q:'DA
. W ?40,$J(NUM+HALF,3)_" "_$E($P(ORDIALOG(PROMPT,"LIST",NUM+HALF),U,2),1,36)
.I (NUM+$G(VALM("TM"))=24)&(NUM'=$S($G(SCR)'=""&($G(ORTAB)="ORDERS"):19,1:20)) S DIR(0)="E" D ^DIR K DIR
Q
;
BROAD(PROC) ; -- Ck PROC type vs ORBROAD
Q:'ORBROAD Q:$P($G(^ORD(101.43,+PROC,"RA")),U,2)'="B"
K DONE W $C(7),!,"You may not select a broad procedure!",!
Q
;
LKP ; -- Special lookup on [common] procedures
N ORX,I,J,Z,BEG,END K ORMORE
I X'[",",X'["-" S Y=$$FIND^ORCDLG2("ORDIALOG("_PROMPT_",""LIST"")",X) D:'$L(Y) DIC^ORCDLG2 Q
S ORX=X F I=1:1:$L(ORX,",") S X=$P(ORX,",",I) I $L(X) D
. I 'X S ORMORE=+$G(ORMORE)+1,ORMORE(ORMORE)=U_X Q
. I X'?1.2N,X'?1.N1"-"1.N Q
. S BEG=+X,END=+$P(X,"-",2) S:'END END=X
. F J=BEG:1:END S Z=$G(ORDIALOG(PROMPT,"LIST",J)) S:Z ORMORE=+$G(ORMORE)+1,ORMORE(ORMORE)=Z
D NEXTPROC
Q
;
NEXTPROC ; -- Gets next procedure in ORMORE()
Q:$G(ORDIALOG(PROMPT,INST))
N I,X S I=$O(ORMORE(0)) I 'I K ORMORE Q
S X=$G(ORMORE(I)),ORMORE=ORMORE-1 K ORMORE(I)
W !!,"For "_$P(ORDIALOG(PROMPT,"A"),":")_" "_$P(X,U,2)_":"
S:X Y=X,ORDIALOG(PROMPT,INST)=+X,EDITONLY=1
I 'X S X=$P(X,U,2) D DIC^ORCDLG2 S:Y'>0 ORQUIT=1 S:Y>0 ORDIALOG(PROMPT,INST)=+Y,EDITONLY=1
Q
ORCDRA ; SLC/MKB - Utility functions for RA dialogs ;7/23/01 11:47
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,53,95,141**;Dec 17, 1997
+2 ;
EN ; -- Entry action for RA OERR EXAM order dialog
+1 IF $GET(ORTAB)="ORDERS"
DO LAST7
ENA ;enter here for Quick Setup (editor) instead
NEW ENT
DO ITYPE
+1 SET ENT="ALL"_$SELECT($GET(ORDIV):"^DIV.`"_ORDIV,1:"")
+2 SET ORBROAD=$$GET^XPAR(ENT,"RA REQUIRE DETAILED",1,"Q")
+3 QUIT
+4 ;
EX ; -- Exit action for RA OERR EXAM order dialog
+1 KILL ORBROAD,ORIMTYPE,ORIMLOC,ORMORE,ORDIV
+2 QUIT
+3 ;
LAST7 ; -- Display last 7 days of exams for patient
+1 NEW IDT,EXDT,EXAM,STS,Y
+2 IF $GET(ORTYPE)="Q"
QUIT
IF $GET(ORACT)="XX"
QUIT
IF $GET(ORACT)="RN"
QUIT
+3 KILL ^TMP($JOB,"RAE7")
DO EN2^RAO7PC1(+ORVP)
+4 ; no exams
IF '$ORDER(^TMP($JOB,"RAE7",+ORVP,0))
QUIT
SET IDT=0
+5 WRITE !!,"Case # Exams Over the Last 7 Days Exam Date Status of Exam Imaging Loc.",!,"------ -------------------------- --------- -------------- ------------"
+6 FOR
SET IDT=$ORDER(^TMP($JOB,"RAE7",+ORVP,IDT))
IF IDT'>0
QUIT
SET EXAM=$GET(^(IDT))
Begin DoDot:1
+7 SET Y=$PIECE(9999999-$PIECE(IDT,"-"),".")
XECUTE ^DD("DD")
+8 SET STS=$PIECE(EXAM,U,3)
SET STS=$SELECT(STS="V":"VERIFIED",STS="R":"RELEASED/UNVER",STS="N":"NO REPORT",STS="P":"PARTIAL",1:"")
+9 WRITE !,$EXTRACT($PIECE(EXAM,U,2),1,9),?10,$EXTRACT($PIECE(EXAM,U),1,28),?39,Y_" "_STS,?67,$EXTRACT($PIECE(EXAM,U,5),1,12)
End DoDot:1
+10 KILL ^TMP($JOB,"RAE7")
WRITE !
+11 QUIT
+12 ;
ITYPE ; -- Select Imaging Type for ordering, sets ORIMTYPE
+1 NEW XRAY,DA,DG,DG0,ABBREV,CNT,ITYPE,DIC,X,Y,I,NAME,OI,IFN,ORY
+2 IF $GET(ORTYPE)="Q"
SET ORDG=ORDG_U_$GET(^ORD(100.98,+ORDG,0))
GOTO ITQ
+3 ; edit
IF $GET(ORIFN)
SET DG=+$PIECE(^OR(100,+ORIFN,0),U,11)
SET ORDG=DG_U_$GET(^ORD(100.98,DG,0))
GOTO ITQ
+4 SET XRAY=$ORDER(^ORD(100.98,"B","XRAY",0))
SET (DA,CNT)=0
+5 IF $GET(ORTYPE)="Z"
IF ORDG'=XRAY
SET ORDG=ORDG_U_$GET(^ORD(100.98,+ORDG,0))
GOTO ITQ
+6 FOR
SET DA=$ORDER(^ORD(100.98,XRAY,1,DA))
IF DA'>0
QUIT
SET DG=$GET(^(DA,0))
Begin DoDot:1
+7 SET DG0=$GET(^ORD(100.98,DG,0))
SET ABBREV=$PIECE(DG0,U,3)
+8 ;I $D(^ORD(101.43,"S."_ABBREV)) S CNT=CNT+1,ITYPE(ABBREV)=DG_U_DG0
+9 IF $$ACTIVE(ABBREV)
SET CNT=CNT+1
SET ITYPE(ABBREV)=DG_U_DG0
End DoDot:1
+10 IF 'CNT
WRITE $CHAR(7),!!,"No active Imaging Types defined!",!
HANG 3
SET ORQUIT=1
QUIT
+11 IF CNT=1
SET I=$ORDER(ITYPE(""))
SET ORDG=ITYPE(I)
GOTO ITQ
+12 WRITE !!,"Select one of the following imaging types:"
+13 SET I=""
FOR
SET I=$ORDER(ITYPE(I))
IF I=""
QUIT
WRITE !," "_$PIECE(ITYPE(I),U,2)
+14 SET DIC="^RA(79.2,"
SET DIC(0)="AEQMZ"
SET DIC("A")="Select IMAGING TYPE: "
+15 SET DIC("S")="I $D(ITYPE($P(^(0),U,3)))"
WRITE !
+16 DO ^DIC
IF $DATA(DTOUT)!$DATA(DUOUT)!(Y<0)
SET ORQUIT=1
QUIT
+17 SET ORDG=ITYPE($PIECE(Y(0),U,3))
ITQ SET NAME=$PIECE(ORDG,U,3)
SET OI=$$PTR^ORCD("OR GTX ORDERABLE ITEM")
+1 SET ORDIALOG(OI,"A")=NAME_" Procedure: "
SET ORDIALOG(OI,"?")="Enter the "_NAME_" procedure to be ordered for this patient"
+2 SET ITYPE=$PIECE(ORDG,U,4)
SET ORIMTYPE=$ORDER(^RA(79.2,"C",ITYPE,0))
+3 SET ORDIALOG(OI,"D")="S."_ITYPE_";C."_ITYPE
+4 ; screen modifiers on ImType
IF ORIMTYPE
Begin DoDot:1
+5 NEW PTR
SET PTR=$$PTR^ORCD("OR GTX MODIFIERS")
IF 'PTR
QUIT
+6 SET ORDIALOG(PTR,"S")="I $D(^RAMIS(71.2,""AB"","_ORIMTYPE_",+Y))"
End DoDot:1
+7 SET ORDIV=$$DIV^ORCDRA1
DO EN4^RAO7PC1(ITYPE,"ORY")
+8 ; I $P(ORY(IFN),U,3)=ORDIV
SET (IFN,CNT)=0
FOR
SET IFN=$ORDER(ORY(IFN))
IF IFN'>0
QUIT
SET CNT=CNT+1
SET ORIMLOC(CNT)=ORY(IFN)
SET ORIMLOC("B",$PIECE(ORY(IFN),U,2))=IFN
+9 ; don't present any choices
IF '$$GET^XPAR("ALL^DIV.`"_ORDIV,"RA SUBMIT PROMPT",1,"Q")
IF CNT>1
KILL ORIMLOC
+10 IF '$TEST
SET ORIMLOC=CNT_"^1"
+11 QUIT
+12 ;
ACTIVE(DG) ; -- Returns 1 or 0, if active OI's exist for DG
+1 NEW X,Y,IDX,ROOT,NOW
SET Y=0
+2 IF '$LENGTH($GET(DG))
GOTO ACTQ
IF '$DATA(^ORD(101.43,"S."_DG))
GOTO ACTQ
+3 SET IDX="^ORD(101.43,""S."_DG_""")"
SET ROOT=$TRANSLATE(IDX,")",",")
SET NOW=$$NOW^XLFDT
+4 ;at least one active orderable in index
FOR
SET IDX=$QUERY(@IDX)
IF $EXTRACT(IDX,1,$LENGTH(ROOT))'=ROOT
QUIT
SET X=$PIECE(@IDX,U,3)
IF 'X!(X>NOW)
SET Y=1
QUIT
ACTQ QUIT Y
+1 ;
COMMON ; -- Build ORDIALOG(PROMPT,"LIST") of Common Procedures
+1 NEW CNT,ITYPE,NAME,DA
KILL ORDIALOG(PROMPT,"LIST")
+2 IF '$DATA(ORDG)
SET ORDG=$PIECE(^ORD(101.41,+ORDIALOG,0),U,5)
SET ORDG=ORDG_U_$GET(^ORD(100.98,+ORDG,0))
+3 SET ITYPE=$PIECE(^ORD(100.98,+ORDG,0),U,3)
IF '$DATA(^ORD(101.43,"COMMON",ITYPE))
QUIT
+4 SET NAME=""
SET CNT=0
+5 FOR
SET NAME=$ORDER(^ORD(101.43,"COMMON",ITYPE,NAME))
IF NAME=""
QUIT
SET DA=$ORDER(^(NAME,0))
SET CNT=CNT+1
SET ORDIALOG(PROMPT,"LIST",CNT)=DA_U_NAME
+6 SET ORDIALOG(PROMPT,"LIST")=CNT
+7 IF CNT
SET $PIECE(ORDIALOG(PROMPT,"?"),";",2)=" select either the number of a common procedure listed above or the name of any "_$$LOW^XLFSTR($PIECE(ORDG,U,2))_" procedure"
+8 QUIT
+9 ;
LIST ; -- List Common Procedures in ORDIALOG(PROMPT,"LIST") for selection
+1 NEW NUM,DA,HALF,DIR,Y
IF '$ORDER(ORDIALOG(PROMPT,"LIST",0))
QUIT
+2 SET HALF=ORDIALOG(PROMPT,"LIST")\2
+3 IF ORDIALOG(PROMPT,"LIST")\2*2'=ORDIALOG(PROMPT,"LIST")
SET HALF=HALF+1
+4 WRITE !!,"Common "_$$LOWER^VALM1($PIECE(ORDG,U,2))_" Procedures: "
+5 SET Y=1
FOR NUM=1:1:HALF
Begin DoDot:1
+6 SET DA=ORDIALOG(PROMPT,"LIST",NUM)
+7 WRITE !,$JUSTIFY(NUM,3)_" "_$EXTRACT($PIECE(ORDIALOG(PROMPT,"LIST",NUM),U,2),1,36)
+8 SET DA=$GET(ORDIALOG(PROMPT,"LIST",NUM+HALF))
IF 'DA
QUIT
+9 WRITE ?40,$JUSTIFY(NUM+HALF,3)_" "_$EXTRACT($PIECE(ORDIALOG(PROMPT,"LIST",NUM+HALF),U,2),1,36)
+10 IF (NUM+$GET(VALM("TM"))=24)&(NUM'=$SELECT($GET(SCR)'=""&($GET(ORTAB)="ORDERS"):19,1:20))
SET DIR(0)="E"
DO ^DIR
KILL DIR
End DoDot:1
IF '+Y
QUIT
+11 QUIT
+12 ;
BROAD(PROC) ; -- Ck PROC type vs ORBROAD
+1 IF 'ORBROAD
QUIT
IF $PIECE($GET(^ORD(101.43,+PROC,"RA")),U,2)'="B"
QUIT
+2 KILL DONE
WRITE $CHAR(7),!,"You may not select a broad procedure!",!
+3 QUIT
+4 ;
LKP ; -- Special lookup on [common] procedures
+1 NEW ORX,I,J,Z,BEG,END
KILL ORMORE
+2 IF X'[","
IF X'["-"
SET Y=$$FIND^ORCDLG2("ORDIALOG("_PROMPT_",""LIST"")",X)
IF '$LENGTH(Y)
DO DIC^ORCDLG2
QUIT
+3 SET ORX=X
FOR I=1:1:$LENGTH(ORX,",")
SET X=$PIECE(ORX,",",I)
IF $LENGTH(X)
Begin DoDot:1
+4 IF 'X
SET ORMORE=+$GET(ORMORE)+1
SET ORMORE(ORMORE)=U_X
QUIT
+5 IF X'?1.2N
IF X'?1.N1"-"1.N
QUIT
+6 SET BEG=+X
SET END=+$PIECE(X,"-",2)
IF 'END
SET END=X
+7 FOR J=BEG:1:END
SET Z=$GET(ORDIALOG(PROMPT,"LIST",J))
IF Z
SET ORMORE=+$GET(ORMORE)+1
SET ORMORE(ORMORE)=Z
End DoDot:1
+8 DO NEXTPROC
+9 QUIT
+10 ;
NEXTPROC ; -- Gets next procedure in ORMORE()
+1 IF $GET(ORDIALOG(PROMPT,INST))
QUIT
+2 NEW I,X
SET I=$ORDER(ORMORE(0))
IF 'I
KILL ORMORE
QUIT
+3 SET X=$GET(ORMORE(I))
SET ORMORE=ORMORE-1
KILL ORMORE(I)
+4 WRITE !!,"For "_$PIECE(ORDIALOG(PROMPT,"A"),":")_" "_$PIECE(X,U,2)_":"
+5 IF X
SET Y=X
SET ORDIALOG(PROMPT,INST)=+X
SET EDITONLY=1
+6 IF 'X
SET X=$PIECE(X,U,2)
DO DIC^ORCDLG2
IF Y'>0
SET ORQUIT=1
IF Y>0
SET ORDIALOG(PROMPT,INST)=+Y
SET EDITONLY=1
+7 QUIT
