RABWORD ;HOIFO/JH&MM - Radiology Billing Awareness ; 04 Apr 2014 6:54 AM
;;5.0;Radiology/Nuclear Medicine;**41,57,70,1003,1006**;Nov 01, 2010;Build 2
;
; Rtn invokes IA #226-C, #1300-A, #2083, #10082, #2343, #4419
Q
;
ASK(RADFN,RASDDT) ; Ask ICD DX & SC/EI/MST/HNC questions at time of Order.
;
;IHS/BJI/DAY - Patch 1006 ICD-10
;Do not ask or display Diagnosis
Q
;End Patch
;
; Called from BAQUES^RAORD1
Q:'$D(^XUSEC("PROVIDER",DUZ)) ;user provider key check
;IHS/BJI/DAY - Patch 1003 - Comment out call to VA's IBB package
;Q:'$$CIDC^IBBAPI(RADFN) ;patient insurance & CIDC switch check
;End Patch
N DIC,I11,RACNT,RADUP,RAQUIT,RABCOPY,RABASEC K RAKILL S RABASEC=0
;if previous order's ICD9 etc. were copied, then put them in RABWDX to file
I $D(^TMP("RACOPY",$J)) D
.;remove copied CV value from piece 8 of RABWDX(1) and all RABWDX(RACNT)
.I ^TMP("RACOPY",$J,"BA") S RABWDX(1)=^("BA"),$P(RABWDX(1),U,8)=""
.S RABCOPY=0,RACNT=1
.F S RABCOPY=$O(^TMP("RACOPY",$J,"BA",RABCOPY)) Q:'RABCOPY S RACNT=RACNT+1,RABWDX(RACNT)=^(RABCOPY),$P(RABWDX(RACNT),U,8)=""
PRIMDX I $D(^TMP("RACOPY",$J,"BA")) D
.S RABCOPY(1)=^TMP("RACOPY",$J,"BA")
.D BADISP^RABWORD1(.RABCOPY)
S DIC="^ICD9(",DIC(0)="QEAMNZ"
S DIC("A")="Ordering ICD-9 Diagnosis: "
S DIC("B")="" I $D(RABWDX(1))&($P($G(RABWDX(1)),U)>0) S DIC("B")=$P(^ICD9(+RABWDX(1),0),U)
I $D(RABCOPY) S DIC("B")=$P(RABCOPY(1),U) K RABCOPY
;IHS/BJI/DAY - Patch 1003 - ICD lookup returns inactive ($$EFF^ICDSUPT)
;S DIC("S")="I $P($$ICDDX^ICDCODE(Y,DT),U,10)" D ^DIC
D ^DIC
;End patch
S:(+Y<0) Y=0
S:Y="^" RAQUIT=1
I (+Y>0) D
.S RACNT=1,$P(RABWDX(RACNT),U,1)=+Y D BAQUES S Y=1
; check @ deletion of previous entry
I X="@" K RABWDX(1)
Q:'$D(RABWDX)!$G(RAQUIT)
;
SECDX F I11=1:1:7 Q:($G(RAQUIT)&'$O(RABWDX(I11))) W ! D
.I $D(^TMP("RACOPY",$J,"BA"))&(RABASEC'="") D
..S RABASEC=$O(^TMP("RACOPY",$J,"BA",RABASEC))
..Q:RABASEC=""
..S RABCOPY(2)=^TMP("RACOPY",$J,"BA",RABASEC)
..D BADISP^RABWORD1(.RABCOPY)
.S DIC="^ICD9(",DIC(0)="QEAMNZ"
.S DIC("A")="Secondary Ordering ICD-9 Diagnosis: "
.S DIC("B")="" I $D(RABWDX(I11+1)) S DIC("B")=$P(^ICD9(+RABWDX(I11+1),0),U)
.I $D(RABCOPY(2)) S DIC("B")=$P(RABCOPY(2),U) K RABCOPY
.;IHS/BJI/DAY - Patch 1003 - ICD lookup returns inactive ($$EFF^ICDSUPT)
.;S DIC("S")="I $P($$ICDDX^ICDCODE(Y,DT),U,10)" D ^DIC
.D ^DIC
.;End patch
.; delete node RABWDX() if its secondary ICD9 was @-deleted
.I X="@" K RABWDX(I11+1)
.I +Y<1 S RAQUIT=1 Q ; No More Secondary ICD Dx to Enter.
.S RADUP=0 D DUPDX
.I RADUP W !?5,"* Cannot Enter Duplicate ICD-9 Diagnosis *" S I11=I11-1 Q
.S RACNT=RACNT+1,$P(RABWDX(RACNT),U,1)=+Y D BAQUES
K ^TMP("RACOPY",$J)
Q ; Quit back to RAORD1 routine.
;
BAQUES ; Ask the SC/EI/MST/HNC questions associated to each ICD Dx.
N RASEQ,RASEQ1,RASEQ2,RAI0,RASDCLY,RAQUES,RADEFLT,RAEXHELP
S RASDCLY=""
D CL^SDCO21(RADFN,RASDDT,"",.RASDCLY)
; non-null value in RASDCLY() means that indicator should be asked
; Current Question Sequence is: SC, CV, AO, IR, EC, SHAD, MST, HNC
S RASEQ="3,7,1,2,4,8,5,6" ; Same Question Sequence as in $$SEQ^SDCO21
F RAI0=1:1:$L(RASEQ,",") Q:$G(RAQUIT) S RASEQ1=+$P(RASEQ,",",RAI0) I $D(RASDCLY(RASEQ1)) D
.S RAQUES="Was treatment related to "_$P($G(^SD(409.41,RASEQ1,0)),U,6)
.I RASEQ1=3 S RAQUES="Was treatment for a SC Condition"
.S RAEXHELP=$S(RASEQ1=3:"D DIS^DGRPDB",1:"")
.S RASEQ2=$S(RASEQ1=3:2,RASEQ1=1:3,RASEQ1=2:4,1:RASEQ1+1)
.; if no user entry for CV, default to Yes; else keep user entry for CV
.S RADEFLT=$S($P(RABWDX(RACNT),U,RASEQ2)=1:"Yes",$P(RABWDX(RACNT),U,RASEQ2)=0:"NO",RASEQ2=8:"Yes",1:"")
.I RADEFLT=""&($D(^TMP("RACOPY",$J))) D
..;find matching DX from Prim and Sec "RACOPY" nodes
..I $P(^TMP("RACOPY",$J,"BA"),U,1)=$P(RABWDX(RACNT),U,1) S RADEFLT=$S($P(^TMP("RACOPY",$J,"BA"),U,RASEQ2)=1:"Yes",$P(^TMP("RACOPY",$J,"BA"),U,RASEQ2)=0:"No",1:"")
..I $D(^TMP("RACOPY",$J,"BA",$P(RABWDX(RACNT),U,1))) S RADEFLT=$S($P(^TMP("RACOPY",$J,"BA",$P(RABWDX(RACNT),U,1)),U,RASEQ2)=1:"Yes",$P(^TMP("RACOPY",$J,"BA",$P(RABWDX(RACNT),U,1)),U,RASEQ2)=0:"No",1:"")
.S $P(RABWDX(RACNT),U,RASEQ2)=$S($P(RABWDX(RACNT),U,1)>0:$$ASKYN(RAQUES,RADEFLT,RAEXHELP),1:0)
Q
;
ASKYN(RAQUES,RADEFLT,RAEXHELP) ; Ask Yes/No Questions
N DIR,DIRUT,DUOUT,DTOUT
I $G(RAEXHELP)'="" S DIR("??")="^"_RAEXHELP
S DIR("A")=" "_RAQUES,DIR(0)="YO"
S DIR("B")=RADEFLT D ^DIR
S:Y="^" RAQUIT=1
I $D(DIRUT)!($D(DTOUT))!($D(DUOUT)) S Y="" ; user typed @ , ^ , or timed out
Q Y
;
DUPDX ; Check If A Duplicate ICD Dx Has Been Entered.
N I
F I=1:1 Q:'$D(RABWDX(I)) I (I11+1)'=I,+Y=+RABWDX(I) S RADUP=1 Q
Q
;
PROV() ; Validate for Provider Key, Active, and non-Terminated statuses.
; Original DIC("S") for Requesting Provider.
; Y = ien file #200
S RACRE=0 ; 1 = person is Active and Credentialed; 0 = otherwise
; Check PROVIDER KEY
I $$ACTIVE^XUSER(Y),$D(^XUSEC("PROVIDER",Y)) S RACRE=1
Q RACRE
;
FILEDX(RADFN,RAO) ; Store SC/EI Fields in Order file #75.1
; Called from RAORD1 routine.
I '$D(RABWDX) G PFSS
N RA1,RA11,RA2,RAFDA,RAIEN,RAMSG
S RAFDA(75.1,RAO_",",91)=+RABWDX(1) ; Primary Ordering ICD Dx pointer.
F RA1=2:1:9 D
.S RA11=$S(RA1<8:RA1,1:RA1+1) ;Skip a field # for CV
.S RAFDA(75.1,RAO_",",(90+RA11))=$P(RABWDX(1),U,RA1)
D FILE^DIE("K","RAFDA","RAMSG") K RAFDA,RAMSG
S RA1=1
F S RA1=$O(RABWDX(RA1)) Q:RA1="" D
.S RAFDA(75.13,"?+2,"_RAO_",",.01)=+RABWDX(RA1)
.F RA2=2:1:9 D
..S RAFDA(75.13,"?+2,"_RAO_",",RA2)=$P(RABWDX(RA1),U,RA2)
.D UPDATE^DIE("","RAFDA","RAIEN","RAMSG") K RAFDA,RAIEN,RAMSG
.Q
PFSS ; RAO is the IEN of file #75.1
; we need to make this call before testing for RABWDX because the GETACCT
; must be done regardless of presence of the RABWDX array
;IHS/BJI/DAY - Patch 1003 - Comment out call to VA's IBB package
;I '$D(RACPRS) D FB^RABWIBB(RAO) ; Requirement 1
;End Patch
Q
RABWORD ;HOIFO/JH&MM - Radiology Billing Awareness ; 04 Apr 2014 6:54 AM
+1 ;;5.0;Radiology/Nuclear Medicine;**41,57,70,1003,1006**;Nov 01, 2010;Build 2
+2 ;
+3 ; Rtn invokes IA #226-C, #1300-A, #2083, #10082, #2343, #4419
+4 QUIT
+5 ;
ASK(RADFN,RASDDT) ; Ask ICD DX & SC/EI/MST/HNC questions at time of Order.
+1 ;
+2 ;IHS/BJI/DAY - Patch 1006 ICD-10
+3 ;Do not ask or display Diagnosis
+4 QUIT
+5 ;End Patch
+6 ;
+7 ; Called from BAQUES^RAORD1
+8 ;user provider key check
IF '$DATA(^XUSEC("PROVIDER",DUZ))
QUIT
+9 ;IHS/BJI/DAY - Patch 1003 - Comment out call to VA's IBB package
+10 ;Q:'$$CIDC^IBBAPI(RADFN) ;patient insurance & CIDC switch check
+11 ;End Patch
+12 NEW DIC,I11,RACNT,RADUP,RAQUIT,RABCOPY,RABASEC
KILL RAKILL
SET RABASEC=0
+13 ;if previous order's ICD9 etc. were copied, then put them in RABWDX to file
+14 IF $DATA(^TMP("RACOPY",$JOB))
Begin DoDot:1
+15 ;remove copied CV value from piece 8 of RABWDX(1) and all RABWDX(RACNT)
+16 IF ^TMP("RACOPY",$JOB,"BA")
SET RABWDX(1)=^("BA")
SET $PIECE(RABWDX(1),U,8)=""
+17 SET RABCOPY=0
SET RACNT=1
+18 FOR
SET RABCOPY=$ORDER(^TMP("RACOPY",$JOB,"BA",RABCOPY))
IF 'RABCOPY
QUIT
SET RACNT=RACNT+1
SET RABWDX(RACNT)=^(RABCOPY)
SET $PIECE(RABWDX(RACNT),U,8)=""
End DoDot:1
PRIMDX IF $DATA(^TMP("RACOPY",$JOB,"BA"))
Begin DoDot:1
+1 SET RABCOPY(1)=^TMP("RACOPY",$JOB,"BA")
+2 DO BADISP^RABWORD1(.RABCOPY)
End DoDot:1
+3 SET DIC="^ICD9("
SET DIC(0)="QEAMNZ"
+4 SET DIC("A")="Ordering ICD-9 Diagnosis: "
+5 SET DIC("B")=""
IF $DATA(RABWDX(1))&($PIECE($GET(RABWDX(1)),U)>0)
SET DIC("B")=$PIECE(^ICD9(+RABWDX(1),0),U)
+6 IF $DATA(RABCOPY)
SET DIC("B")=$PIECE(RABCOPY(1),U)
KILL RABCOPY
+7 ;IHS/BJI/DAY - Patch 1003 - ICD lookup returns inactive ($$EFF^ICDSUPT)
+8 ;S DIC("S")="I $P($$ICDDX^ICDCODE(Y,DT),U,10)" D ^DIC
+9 DO ^DIC
+10 ;End patch
+11 IF (+Y<0)
SET Y=0
+12 IF Y="^"
SET RAQUIT=1
+13 IF (+Y>0)
Begin DoDot:1
+14 SET RACNT=1
SET $PIECE(RABWDX(RACNT),U,1)=+Y
DO BAQUES
SET Y=1
End DoDot:1
+15 ; check @ deletion of previous entry
+16 IF X="@"
KILL RABWDX(1)
+17 IF '$DATA(RABWDX)!$GET(RAQUIT)
QUIT
+18 ;
SECDX FOR I11=1:1:7
IF ($GET(RAQUIT)&'$ORDER(RABWDX(I11)))
QUIT
WRITE !
Begin DoDot:1
+1 IF $DATA(^TMP("RACOPY",$JOB,"BA"))&(RABASEC'="")
Begin DoDot:2
+2 SET RABASEC=$ORDER(^TMP("RACOPY",$JOB,"BA",RABASEC))
+3 IF RABASEC=""
QUIT
+4 SET RABCOPY(2)=^TMP("RACOPY",$JOB,"BA",RABASEC)
+5 DO BADISP^RABWORD1(.RABCOPY)
End DoDot:2
+6 SET DIC="^ICD9("
SET DIC(0)="QEAMNZ"
+7 SET DIC("A")="Secondary Ordering ICD-9 Diagnosis: "
+8 SET DIC("B")=""
IF $DATA(RABWDX(I11+1))
SET DIC("B")=$PIECE(^ICD9(+RABWDX(I11+1),0),U)
+9 IF $DATA(RABCOPY(2))
SET DIC("B")=$PIECE(RABCOPY(2),U)
KILL RABCOPY
+10 ;IHS/BJI/DAY - Patch 1003 - ICD lookup returns inactive ($$EFF^ICDSUPT)
+11 ;S DIC("S")="I $P($$ICDDX^ICDCODE(Y,DT),U,10)" D ^DIC
+12 DO ^DIC
+13 ;End patch
+14 ; delete node RABWDX() if its secondary ICD9 was @-deleted
+15 IF X="@"
KILL RABWDX(I11+1)
+16 ; No More Secondary ICD Dx to Enter.
IF +Y<1
SET RAQUIT=1
QUIT
+17 SET RADUP=0
DO DUPDX
+18 IF RADUP
WRITE !?5,"* Cannot Enter Duplicate ICD-9 Diagnosis *"
SET I11=I11-1
QUIT
+19 SET RACNT=RACNT+1
SET $PIECE(RABWDX(RACNT),U,1)=+Y
DO BAQUES
End DoDot:1
+20 KILL ^TMP("RACOPY",$JOB)
+21 ; Quit back to RAORD1 routine.
QUIT
+22 ;
BAQUES ; Ask the SC/EI/MST/HNC questions associated to each ICD Dx.
+1 NEW RASEQ,RASEQ1,RASEQ2,RAI0,RASDCLY,RAQUES,RADEFLT,RAEXHELP
+2 SET RASDCLY=""
+3 DO CL^SDCO21(RADFN,RASDDT,"",.RASDCLY)
+4 ; non-null value in RASDCLY() means that indicator should be asked
+5 ; Current Question Sequence is: SC, CV, AO, IR, EC, SHAD, MST, HNC
+6 ; Same Question Sequence as in $$SEQ^SDCO21
SET RASEQ="3,7,1,2,4,8,5,6"
+7 FOR RAI0=1:1:$LENGTH(RASEQ,",")
IF $GET(RAQUIT)
QUIT
SET RASEQ1=+$PIECE(RASEQ,",",RAI0)
IF $DATA(RASDCLY(RASEQ1))
Begin DoDot:1
+8 SET RAQUES="Was treatment related to "_$PIECE($GET(^SD(409.41,RASEQ1,0)),U,6)
+9 IF RASEQ1=3
SET RAQUES="Was treatment for a SC Condition"
+10 SET RAEXHELP=$SELECT(RASEQ1=3:"D DIS^DGRPDB",1:"")
+11 SET RASEQ2=$SELECT(RASEQ1=3:2,RASEQ1=1:3,RASEQ1=2:4,1:RASEQ1+1)
+12 ; if no user entry for CV, default to Yes; else keep user entry for CV
+13 SET RADEFLT=$SELECT($PIECE(RABWDX(RACNT),U,RASEQ2)=1:"Yes",$PIECE(RABWDX(RACNT),U,RASEQ2)=0:"NO",RASEQ2=8:"Yes",1:"")
+14 IF RADEFLT=""&($DATA(^TMP("RACOPY",$JOB)))
Begin DoDot:2
+15 ;find matching DX from Prim and Sec "RACOPY" nodes
+16 IF $PIECE(^TMP("RACOPY",$JOB,"BA"),U,1)=$PIECE(RABWDX(RACNT),U,1)
SET RADEFLT=$SELECT($PIECE(^TMP("RACOPY",$JOB,"BA"),U,RASEQ2)=1:"Yes",$PIECE(^TMP("RACOPY",$JOB,"BA"),U,RASEQ2)=0:"No",1:"")
+17 IF $DATA(^TMP("RACOPY",$JOB,"BA",$PIECE(RABWDX(RACNT),U,1)))
SET RADEFLT=$SELECT($PIECE(^TMP("RACOPY",$JOB,"BA",$PIECE(RABWDX(RACNT),U,1)),U,RASEQ2)=1:"Yes",$PIECE(^TMP("RACOPY",$JOB,"BA",$PIECE(RABWDX(RACNT),U,1)),U,RASEQ2)=0:"No",1:"")
End DoDot:2
+18 SET $PIECE(RABWDX(RACNT),U,RASEQ2)=$SELECT($PIECE(RABWDX(RACNT),U,1)>0:$$ASKYN(RAQUES,RADEFLT,RAEXHELP),1:0)
End DoDot:1
+19 QUIT
+20 ;
ASKYN(RAQUES,RADEFLT,RAEXHELP) ; Ask Yes/No Questions
+1 NEW DIR,DIRUT,DUOUT,DTOUT
+2 IF $GET(RAEXHELP)'=""
SET DIR("??")="^"_RAEXHELP
+3 SET DIR("A")=" "_RAQUES
SET DIR(0)="YO"
+4 SET DIR("B")=RADEFLT
DO ^DIR
+5 IF Y="^"
SET RAQUIT=1
+6 ; user typed @ , ^ , or timed out
IF $DATA(DIRUT)!($DATA(DTOUT))!($DATA(DUOUT))
SET Y=""
+7 QUIT Y
+8 ;
DUPDX ; Check If A Duplicate ICD Dx Has Been Entered.
+1 NEW I
+2 FOR I=1:1
IF '$DATA(RABWDX(I))
QUIT
IF (I11+1)'=I
IF +Y=+RABWDX(I)
SET RADUP=1
QUIT
+3 QUIT
+4 ;
PROV() ; Validate for Provider Key, Active, and non-Terminated statuses.
+1 ; Original DIC("S") for Requesting Provider.
+2 ; Y = ien file #200
+3 ; 1 = person is Active and Credentialed; 0 = otherwise
SET RACRE=0
+4 ; Check PROVIDER KEY
+5 IF $$ACTIVE^XUSER(Y)
IF $DATA(^XUSEC("PROVIDER",Y))
SET RACRE=1
+6 QUIT RACRE
+7 ;
FILEDX(RADFN,RAO) ; Store SC/EI Fields in Order file #75.1
+1 ; Called from RAORD1 routine.
+2 IF '$DATA(RABWDX)
GOTO PFSS
+3 NEW RA1,RA11,RA2,RAFDA,RAIEN,RAMSG
+4 ; Primary Ordering ICD Dx pointer.
SET RAFDA(75.1,RAO_",",91)=+RABWDX(1)
+5 FOR RA1=2:1:9
Begin DoDot:1
+6 ;Skip a field # for CV
SET RA11=$SELECT(RA1<8:RA1,1:RA1+1)
+7 SET RAFDA(75.1,RAO_",",(90+RA11))=$PIECE(RABWDX(1),U,RA1)
End DoDot:1
+8 DO FILE^DIE("K","RAFDA","RAMSG")
KILL RAFDA,RAMSG
+9 SET RA1=1
+10 FOR
SET RA1=$ORDER(RABWDX(RA1))
IF RA1=""
QUIT
Begin DoDot:1
+11 SET RAFDA(75.13,"?+2,"_RAO_",",.01)=+RABWDX(RA1)
+12 FOR RA2=2:1:9
Begin DoDot:2
+13 SET RAFDA(75.13,"?+2,"_RAO_",",RA2)=$PIECE(RABWDX(RA1),U,RA2)
End DoDot:2
+14 DO UPDATE^DIE("","RAFDA","RAIEN","RAMSG")
KILL RAFDA,RAIEN,RAMSG
+15 QUIT
End DoDot:1
PFSS ; RAO is the IEN of file #75.1
+1 ; we need to make this call before testing for RABWDX because the GETACCT
+2 ; must be done regardless of presence of the RABWDX array
+3 ;IHS/BJI/DAY - Patch 1003 - Comment out call to VA's IBB package
+4 ;I '$D(RACPRS) D FB^RABWIBB(RAO) ; Requirement 1
+5 ;End Patch
+6 QUIT
