- RABWORD ;HOIFO/JH&MM - Radiology Billing Awareness ;12/20/04 12:55am
- ;;5.0;Radiology/Nuclear Medicine;**41,57,70**;Mar 16, 1998;Build 7
- ;
- ; 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.
- ; Called from BAQUES^RAORD1
- Q:'$D(^XUSEC("PROVIDER",DUZ)) ;user provider key check
- Q:'$$CIDC^IBBAPI(RADFN) ;patient insurance & CIDC switch check
- 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
- S DIC("S")="I $P($$ICDDX^ICDCODE(Y,DT),U,10)" D ^DIC
- 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
- .S DIC("S")="I $P($$ICDDX^ICDCODE(Y,DT),U,10)" D ^DIC
- .; 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
- I '$D(RACPRS) D FB^RABWIBB(RAO) ; Requirement 1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRABWORD 5480 printed Feb 19, 2025@00:00:13 Page 2
- RABWORD ;HOIFO/JH&MM - Radiology Billing Awareness ;12/20/04 12:55am
- +1 ;;5.0;Radiology/Nuclear Medicine;**41,57,70**;Mar 16, 1998;Build 7
- +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 ; Called from BAQUES^RAORD1
- +2 ;user provider key check
- if '$DATA(^XUSEC("PROVIDER",DUZ))
- QUIT
- +3 ;patient insurance & CIDC switch check
- if '$$CIDC^IBBAPI(RADFN)
- QUIT
- +4 NEW DIC,I11,RACNT,RADUP,RAQUIT,RABCOPY,RABASEC
- KILL RAKILL
- SET RABASEC=0
- +5 ;if previous order's ICD9 etc. were copied, then put them in RABWDX to file
- +6 IF $DATA(^TMP("RACOPY",$JOB))
- Begin DoDot:1
- +7 ;remove copied CV value from piece 8 of RABWDX(1) and all RABWDX(RACNT)
- +8 IF ^TMP("RACOPY",$JOB,"BA")
- SET RABWDX(1)=^("BA")
- SET $PIECE(RABWDX(1),U,8)=""
- +9 SET RABCOPY=0
- SET RACNT=1
- +10 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 SET DIC("S")="I $P($$ICDDX^ICDCODE(Y,DT),U,10)"
- DO ^DIC
- +8 if (+Y<0)
- SET Y=0
- +9 if Y="^"
- SET RAQUIT=1
- +10 IF (+Y>0)
- Begin DoDot:1
- +11 SET RACNT=1
- SET $PIECE(RABWDX(RACNT),U,1)=+Y
- DO BAQUES
- SET Y=1
- End DoDot:1
- +12 ; check @ deletion of previous entry
- +13 IF X="@"
- KILL RABWDX(1)
- +14 if '$DATA(RABWDX)!$GET(RAQUIT)
- QUIT
- +15 ;
- 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 SET DIC("S")="I $P($$ICDDX^ICDCODE(Y,DT),U,10)"
- DO ^DIC
- +11 ; delete node RABWDX() if its secondary ICD9 was @-deleted
- +12 IF X="@"
- KILL RABWDX(I11+1)
- +13 ; No More Secondary ICD Dx to Enter.
- IF +Y<1
- SET RAQUIT=1
- QUIT
- +14 SET RADUP=0
- DO DUPDX
- +15 IF RADUP
- WRITE !?5,"* Cannot Enter Duplicate ICD-9 Diagnosis *"
- SET I11=I11-1
- QUIT
- +16 SET RACNT=RACNT+1
- SET $PIECE(RABWDX(RACNT),U,1)=+Y
- DO BAQUES
- End DoDot:1
- +17 KILL ^TMP("RACOPY",$JOB)
- +18 ; Quit back to RAORD1 routine.
- QUIT
- +19 ;
- 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 ; Requirement 1
- IF '$DATA(RACPRS)
- DO FB^RABWIBB(RAO)
- +4 QUIT