Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RABWORD

RABWORD.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; Rtn invokes IA #226-C, #1300-A, #2083, #10082, #2343, #4419
  1. Q
  1. ;
  1. ASK(RADFN,RASDDT) ; Ask ICD DX & SC/EI/MST/HNC questions at time of Order.
  1. ; Called from BAQUES^RAORD1
  1. Q:'$D(^XUSEC("PROVIDER",DUZ)) ;user provider key check
  1. Q:'$$CIDC^IBBAPI(RADFN) ;patient insurance & CIDC switch check
  1. N DIC,I11,RACNT,RADUP,RAQUIT,RABCOPY,RABASEC K RAKILL S RABASEC=0
  1. ;if previous order's ICD9 etc. were copied, then put them in RABWDX to file
  1. I $D(^TMP("RACOPY",$J)) D
  1. .;remove copied CV value from piece 8 of RABWDX(1) and all RABWDX(RACNT)
  1. .I ^TMP("RACOPY",$J,"BA") S RABWDX(1)=^("BA"),$P(RABWDX(1),U,8)=""
  1. .S RABCOPY=0,RACNT=1
  1. .F S RABCOPY=$O(^TMP("RACOPY",$J,"BA",RABCOPY)) Q:'RABCOPY S RACNT=RACNT+1,RABWDX(RACNT)=^(RABCOPY),$P(RABWDX(RACNT),U,8)=""
  1. PRIMDX I $D(^TMP("RACOPY",$J,"BA")) D
  1. .S RABCOPY(1)=^TMP("RACOPY",$J,"BA")
  1. .D BADISP^RABWORD1(.RABCOPY)
  1. S DIC="^ICD9(",DIC(0)="QEAMNZ"
  1. S DIC("A")="Ordering ICD-9 Diagnosis: "
  1. S DIC("B")="" I $D(RABWDX(1))&($P($G(RABWDX(1)),U)>0) S DIC("B")=$P(^ICD9(+RABWDX(1),0),U)
  1. I $D(RABCOPY) S DIC("B")=$P(RABCOPY(1),U) K RABCOPY
  1. S DIC("S")="I $P($$ICDDX^ICDCODE(Y,DT),U,10)" D ^DIC
  1. S:(+Y<0) Y=0
  1. S:Y="^" RAQUIT=1
  1. I (+Y>0) D
  1. .S RACNT=1,$P(RABWDX(RACNT),U,1)=+Y D BAQUES S Y=1
  1. ; check @ deletion of previous entry
  1. I X="@" K RABWDX(1)
  1. Q:'$D(RABWDX)!$G(RAQUIT)
  1. ;
  1. SECDX F I11=1:1:7 Q:($G(RAQUIT)&'$O(RABWDX(I11))) W ! D
  1. .I $D(^TMP("RACOPY",$J,"BA"))&(RABASEC'="") D
  1. ..S RABASEC=$O(^TMP("RACOPY",$J,"BA",RABASEC))
  1. ..Q:RABASEC=""
  1. ..S RABCOPY(2)=^TMP("RACOPY",$J,"BA",RABASEC)
  1. ..D BADISP^RABWORD1(.RABCOPY)
  1. .S DIC="^ICD9(",DIC(0)="QEAMNZ"
  1. .S DIC("A")="Secondary Ordering ICD-9 Diagnosis: "
  1. .S DIC("B")="" I $D(RABWDX(I11+1)) S DIC("B")=$P(^ICD9(+RABWDX(I11+1),0),U)
  1. .I $D(RABCOPY(2)) S DIC("B")=$P(RABCOPY(2),U) K RABCOPY
  1. .S DIC("S")="I $P($$ICDDX^ICDCODE(Y,DT),U,10)" D ^DIC
  1. .; delete node RABWDX() if its secondary ICD9 was @-deleted
  1. .I X="@" K RABWDX(I11+1)
  1. .I +Y<1 S RAQUIT=1 Q ; No More Secondary ICD Dx to Enter.
  1. .S RADUP=0 D DUPDX
  1. .I RADUP W !?5,"* Cannot Enter Duplicate ICD-9 Diagnosis *" S I11=I11-1 Q
  1. .S RACNT=RACNT+1,$P(RABWDX(RACNT),U,1)=+Y D BAQUES
  1. K ^TMP("RACOPY",$J)
  1. Q ; Quit back to RAORD1 routine.
  1. ;
  1. BAQUES ; Ask the SC/EI/MST/HNC questions associated to each ICD Dx.
  1. N RASEQ,RASEQ1,RASEQ2,RAI0,RASDCLY,RAQUES,RADEFLT,RAEXHELP
  1. S RASDCLY=""
  1. D CL^SDCO21(RADFN,RASDDT,"",.RASDCLY)
  1. ; non-null value in RASDCLY() means that indicator should be asked
  1. ; Current Question Sequence is: SC, CV, AO, IR, EC, SHAD, MST, HNC
  1. S RASEQ="3,7,1,2,4,8,5,6" ; Same Question Sequence as in $$SEQ^SDCO21
  1. F RAI0=1:1:$L(RASEQ,",") Q:$G(RAQUIT) S RASEQ1=+$P(RASEQ,",",RAI0) I $D(RASDCLY(RASEQ1)) D
  1. .S RAQUES="Was treatment related to "_$P($G(^SD(409.41,RASEQ1,0)),U,6)
  1. .I RASEQ1=3 S RAQUES="Was treatment for a SC Condition"
  1. .S RAEXHELP=$S(RASEQ1=3:"D DIS^DGRPDB",1:"")
  1. .S RASEQ2=$S(RASEQ1=3:2,RASEQ1=1:3,RASEQ1=2:4,1:RASEQ1+1)
  1. .; if no user entry for CV, default to Yes; else keep user entry for CV
  1. .S RADEFLT=$S($P(RABWDX(RACNT),U,RASEQ2)=1:"Yes",$P(RABWDX(RACNT),U,RASEQ2)=0:"NO",RASEQ2=8:"Yes",1:"")
  1. .I RADEFLT=""&($D(^TMP("RACOPY",$J))) D
  1. ..;find matching DX from Prim and Sec "RACOPY" nodes
  1. ..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:"")
  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:"")
  1. .S $P(RABWDX(RACNT),U,RASEQ2)=$S($P(RABWDX(RACNT),U,1)>0:$$ASKYN(RAQUES,RADEFLT,RAEXHELP),1:0)
  1. Q
  1. ;
  1. ASKYN(RAQUES,RADEFLT,RAEXHELP) ; Ask Yes/No Questions
  1. N DIR,DIRUT,DUOUT,DTOUT
  1. I $G(RAEXHELP)'="" S DIR("??")="^"_RAEXHELP
  1. S DIR("A")=" "_RAQUES,DIR(0)="YO"
  1. S DIR("B")=RADEFLT D ^DIR
  1. S:Y="^" RAQUIT=1
  1. I $D(DIRUT)!($D(DTOUT))!($D(DUOUT)) S Y="" ; user typed @ , ^ , or timed out
  1. Q Y
  1. ;
  1. DUPDX ; Check If A Duplicate ICD Dx Has Been Entered.
  1. N I
  1. F I=1:1 Q:'$D(RABWDX(I)) I (I11+1)'=I,+Y=+RABWDX(I) S RADUP=1 Q
  1. Q
  1. ;
  1. PROV() ; Validate for Provider Key, Active, and non-Terminated statuses.
  1. ; Original DIC("S") for Requesting Provider.
  1. ; Y = ien file #200
  1. S RACRE=0 ; 1 = person is Active and Credentialed; 0 = otherwise
  1. ; Check PROVIDER KEY
  1. I $$ACTIVE^XUSER(Y),$D(^XUSEC("PROVIDER",Y)) S RACRE=1
  1. Q RACRE
  1. ;
  1. FILEDX(RADFN,RAO) ; Store SC/EI Fields in Order file #75.1
  1. ; Called from RAORD1 routine.
  1. I '$D(RABWDX) G PFSS
  1. N RA1,RA11,RA2,RAFDA,RAIEN,RAMSG
  1. S RAFDA(75.1,RAO_",",91)=+RABWDX(1) ; Primary Ordering ICD Dx pointer.
  1. F RA1=2:1:9 D
  1. .S RA11=$S(RA1<8:RA1,1:RA1+1) ;Skip a field # for CV
  1. .S RAFDA(75.1,RAO_",",(90+RA11))=$P(RABWDX(1),U,RA1)
  1. D FILE^DIE("K","RAFDA","RAMSG") K RAFDA,RAMSG
  1. S RA1=1
  1. F S RA1=$O(RABWDX(RA1)) Q:RA1="" D
  1. .S RAFDA(75.13,"?+2,"_RAO_",",.01)=+RABWDX(RA1)
  1. .F RA2=2:1:9 D
  1. ..S RAFDA(75.13,"?+2,"_RAO_",",RA2)=$P(RABWDX(RA1),U,RA2)
  1. .D UPDATE^DIE("","RAFDA","RAIEN","RAMSG") K RAFDA,RAIEN,RAMSG
  1. .Q
  1. PFSS ; RAO is the IEN of file #75.1
  1. ; we need to make this call before testing for RABWDX because the GETACCT
  1. ; must be done regardless of presence of the RABWDX array
  1. I '$D(RACPRS) D FB^RABWIBB(RAO) ; Requirement 1
  1. Q