RAPCE ;HIRMFO/GJC-Interface with PCE APIs for wrkload, visits ; 20 Apr 2011 7:29 PM
;;5.0;Radiology/Nuclear Medicine;**10,17,21,26,41,57,56,1003**;Nov 01, 2010;Build 3
;Supported IA #2053 FILE^DIE
;Supported IA #4663 SWSTAT^IBBAPI
;Controlled IA #1889 DATA2PCE^PXAPI
Q
COMPLETE(RADFN,RADTI,RACNI) ; When an exam status changes to 'complete'
; Input: RADFN-> Patient DFN, RADTI-> Exam Timestamp, RACNI-> Case IEN
; NOTE: RACNI input param is ignored for exam sets (all cases under
; an exam set are processed at once when order is complete)
; $$DATA2PCE^PXAPI returns: 1 if no errors, else error condition
;
K ^TMP("DIERR",$J),^TMP("RAPXAPI",$J)
N RA7002,RA7003,RA71,RA791,RACNT,RADTE,RAEARRY,RAPKG,RAVSIT,RABAD,RASTAT,RACPTM,RA,RA1,RARECMPL,RACNISAV
N RADUPRC,RACOMIEN,RASENT,RALCKFAL
S RALCKFAL=0 ; >0 if lock fails when :
; 1= complt'g exam that's unique to other cases same dt/tm, if any
; 2= complt'g exam that's a dupl of another cmplt'd exam (RESEND^RAPCE1)
; 3= UNcompleting exam before deleting credit+visit pointers same dt/tm
S RAPKG=$O(^DIC(9.4,"B","RADIOLOGY/NUCLEAR MEDICINE",0))
S RADTE=9999999.9999-RADTI,RACNT=0
S RA7002=$G(^RADPT(RADFN,"DT",RADTI,0))
S RAXAMSET=+$P(RA7002,"^",5) ; is this part of an exam set? 1=YES
EN2 S RA791=$G(^RA(79.1,+$P(RA7002,"^",4),0))
; Initialize variables required for PFSS 1B project and check the switch status.
;IHS/BJI/DAY - Patch 1003 - Comment out call to VA's IBB pkg - set variable
;N RAPFSW,RACCOUNT S RAPFSW=$$SWSTAT^IBBAPI ; Requirement 12
N RAPFSW S RAPFSW=0
;End Patch
Q:+$P(RA791,"^",21)=2 ; no credit, quit
S RAEARRY="RAERROR" N @RAEARRY
LON ; lock at P level
L +^RADPT(RADFN,"DT",RADTI,"P",RACNI):30 I '$T S RALCKFAL=1 D FAILBUL^RAPCE2(RADFN,RADTI,RACNI,$S($G(RADUZ):RADUZ,1:DUZ)) Q
I 'RAXAMSET G NONSET
; exam set, grab all the completed records!
S RACNISAV=RACNI
S RACNI=0
F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0!($G(RABAD)) D
. S RA7003=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) I $P($G(^RA(72,+$P(RA7003,U,3),0)),U,3)'=9 Q ;check code instead of name
. S RACNT=RACNT+1 D SETUP I $G(RABAD) Q
. D:'$D(^TMP("RAPXAPI",$J,"ENCOUNTER")) ENC(RACNT)
. D DX^RABWPCE($P(RA7003,U,11)) ; Ordering ICD Dx and related data.
. D PROC(RACNT)
. Q
S RACNI=RACNISAV ;restore value so unlock would work 012601
I '$G(RABAD),$D(^TMP("RAPXAPI",$J)) D PCE(RADFN,RADTI,RACNI)
;Missing data, send failure bulletin for ea case in set, don't attempt to send data to PCE
I $G(RABAD) W:'$D(ZTQUEUED)&('$D(RARECMPL)) !,"Unable to credit Exam set" D
. S RACNI=0 F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0 D FAILBUL^RAPCE2(RADFN,RADTI,RACNI,$S($G(RADUZ):RADUZ,1:DUZ))
G KOUT
NONSET ; non-exam sets
S RA7003=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
D CKDUP^RAPCE1 ; chk for duplicate procedure(s) non-examset
I $G(RADUPRC) D RESEND^RAPCE1 G KOUT ; branch off to re-send rec(s) this dt/tm
S RACNT=RACNT+1
D SETUP
D:'$G(RABAD) ENC(RACNT) D:'$G(RABAD) DX^RABWPCE($P(RA7003,U,11)) D:'$G(RABAD) PROC(RACNT) D:'$G(RABAD) PCE(RADFN,RADTI,RACNI)
I $G(RABAD) W:'$D(ZTQUEUED)&('$D(RARECMPL)) !,"Unable to credit exam" D FAILBUL^RAPCE2(RADFN,RADTI,RACNI,$S($G(RADUZ):RADUZ,1:DUZ)) ;Missing data, send failure bulletin for single case, don't attempt to pass data to PCE
;
KOUT K ^TMP("RAPXAPI",$J)
L -^RADPT(RADFN,"DT",RADTI,"P",RACNI)
Q
ENC(X) ; Set up the '"RAPXAPI",$J,"ENCOUNTER"' nodes
N RAIMGLOC,RA17,RARPTLOC
S RA17=+$P(RA7003,U,17)
S RARPTLOC=$P($G(^RARPT(RA17,"BA")),U,1)
S RAIMGLOC=$P($G(^RA(79.1,+RARPTLOC,0)),"^")
S:'RAIMGLOC RAIMGLOC=$P($G(^RA(79.1,+$P(RA7002,"^",4),0)),"^")
I RAIMGLOC="" S RABAD=1 Q ; needs imaging location
S ^TMP("RAPXAPI",$J,"ENCOUNTER",X,"PATIENT")=RADFN
S ^TMP("RAPXAPI",$J,"ENCOUNTER",X,"ENC D/T")=RADTE
S ^TMP("RAPXAPI",$J,"ENCOUNTER",X,"HOS LOC")=RAIMGLOC
S ^TMP("RAPXAPI",$J,"ENCOUNTER",X,"SERVICE CATEGORY")="X"
S ^TMP("RAPXAPI",$J,"ENCOUNTER",X,"ENCOUNTER TYPE")="A"
Q
PCE(RADFN,RADTI,RACNI) ; Pass on the information to the PCE software
;IHS/BJI/DAY - Patch 1003 - Continue Chris Saddler 2003 patch
;Quit this section, and use IHS calls to PCC instead
Q
;End Patch
N RASULT
; If the PFSS switch is not active then do not pass RACCOUNT parameter to DATA2PCE call.
I 'RAPFSW S RASULT=$$DATA2PCE^PXAPI("^TMP(""RAPXAPI"",$J)",RAPKG,"RAD/NUC MED",.RAVSIT,"","","","",.@RAEARRY)
; If the PFSS switch is active then use RACCOUNT parameter in DATA2PCE call.
I RAPFSW D
. ; PFSS Requirement 6, 11
. S RASULT=$$DATA2PCE^PXAPI("^TMP(""RAPXAPI"",$J)",RAPKG,"RAD/NUC MED",.RAVSIT,"","","","",.@RAEARRY,.RACCOUNT)
. Q
I (RASULT=1)!(RASULT=-1) D ;Visit file pointer, set 'Credit recorded' to yes.
. W:'$D(ZTQUEUED)&('$D(RARECMPL)) !?5,"Visit credited.",!
. D:'RAXAMSET VISIT(RADFN,RADTI,RACNI,RAVSIT)
. D:'RAXAMSET RECDCS(RADFN,RADTI,RACNI) ; only one exam, not a set
. D:RAXAMSET MULCS(RADFN,RADTI) ; set, update all exams!
. S RASENT=1 ; sent to PCE was okay
. Q
E D
. N RAWHOERR S RAWHOERR=""
. W:'$D(ZTQUEUED)&('$D(RARECMPL)) !?5,$C(7),"Unable to credit.",!
. I '$G(RAXAMSET) D FAILBUL^RAPCE2(RADFN,RADTI,RACNI,$S($G(RADUZ):RADUZ,1:DUZ))
. I $G(RAXAMSET) D
.. S RACNI=0 F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0 D FAILBUL^RAPCE2(RADFN,RADTI,RACNI,$S($G(RADUZ):RADUZ,1:DUZ))
.. Q
. Q
Q
MULCS(RADFN,RADTI) ; Update the 'Credit recorded' field and the Visit
;pointer for each case that is complete
N RACNI S RACNI=0
F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0 D
. Q:$P($G(^RA(72,+$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U,3),0)),U,3)'=9
. D RECDCS(RADFN,RADTI,RACNI)
. D VISIT(RADFN,RADTI,RACNI,RAVSIT)
. Q
Q
PROC(X) ; Set up the other '"RAPXAPI",$J,"PROCEDURE"' nodes for this case
; If same procedure repeated in exam set, add to qty of existing
; 'procedure' node. Else, if different provider, create new
; separate 'procedure' nodes
N X1,X2,X3,RADUP F X1=1:1:X S X2=$G(^TMP("RAPXAPI",$J,"PROCEDURE",X1,"PROCEDURE")) I X2=$P(RA71,"^",9),^("ENC PROVIDER")=$S(RA7003(15)]"":RA7003(15),1:RA7003(12)) D Q
. S ^TMP("RAPXAPI",$J,"PROCEDURE",X1,"QTY")=^("QTY")+1
. D CPTMOD(X1)
. S RADUP=1
. Q
I $D(RADUP) Q
S ^TMP("RAPXAPI",$J,"PROCEDURE",X,"QTY")=1
S ^TMP("RAPXAPI",$J,"PROCEDURE",X,"PROCEDURE")=$P(RA71,"^",9)
S ^TMP("RAPXAPI",$J,"PROCEDURE",X,"NARRATIVE")=$P(RA71,"^")
S ^TMP("RAPXAPI",$J,"PROCEDURE",X,"ENC PROVIDER")=$S(RA7003(15)]"":RA7003(15),1:RA7003(12)) ; Pri. Int Staff if exists, else Pri Int Resident
S ^TMP("RAPXAPI",$J,"PROCEDURE",X,"ORD PROVIDER")=RA7003(14) ; Requesting Physician.
S ^TMP("RAPXAPI",$J,"PROCEDURE",X,"EVENT D/T")=RADTE
; if the PFSS switch is active Get both Dept. Code and Account Reference Number (RACCOUNT)
;IHS/BJI/DAY - Patch 1003 - Comment out call to VA's IBB package
;I RAPFSW D GETDEPT^RABWIBB ; Requirement 9
;End Patch
D CPTMOD(X)
D PROCDX^RABWPCE(X) ; Add Ordering ICD Dx to each Procedure.
Q
RECDCS(RADFN,RADTI,RACNI) ; Set 'Clinic Stop Recorded' to yes
; (70.03, fld 23)
N RAFDA S RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",23)="Y"
D FILE^DIE("K","RAFDA")
Q
SETUP ; Setup examination data node information
; If no provider, or inactive CPT, fail
S RA7003=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
S RA7003(12)=$P(RA7003,"^",12) ; Pri. Inter. Resident
S RA7003(14)=$P(RA7003,"^",14) ; Requesting Physician.
S RA7003(15)=$P(RA7003,"^",15) ; Pri. Inter. Staff
; OK to send if missing resident/staff ONLY if report Elec. Filed
I (RA7003(12)="")&(RA7003(15)=""),$P($G(^RARPT(+$P(RA7003,U,17),0)),U,5)'="EF" S RABAD=1 Q
S RA71=$G(^RAMIS(71,+$P(RA7003,"^",2),0))
; store CPT Modifiers' .01 value
K RACPTM S RA=0 F S RA=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",RA)) Q:'RA S RA1=$$BASICMOD^RACPTMSC($P($G(^(RA,0)),"^"),+$P(RA7002,"^")) S:+RA1>0 RACPTM(RA)=$P(RA1,"^",2) ;only valid cpt mods
; find out if CPT code is active
I '$$ACTCODE^RACPTMSC(+$P(RA71,"^",9),$P(RA7002,"^")) S RABAD=1
Q
VISIT(RADFN,RADTI,RACNI,RAVSIT) ; Stuff the Visit file pointer passed back
; from $$DATA2PCE^PXAPI() into the Visit field (70.02, fld 6)
N RAFDA S RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",27)=RAVSIT
D FILE^DIE("K","RAFDA")
Q
CPTMOD(X3) ;CPT Modifiers
; CPT Mods for dupl. procedure+provider will be accounted for
; however, same CPT Mod will overwrite previous CPT Mod
S ^TMP("RAPXAPI",$J,"PROCEDURE",X3,"MODIFIERS")="" ;prevent abend
S RA=0
F S RA=$O(RACPTM(RA)) Q:'RA S ^TMP("RAPXAPI",$J,"PROCEDURE",X3,"MODIFIERS",RACPTM(RA))=""
Q
RAPCE ;HIRMFO/GJC-Interface with PCE APIs for wrkload, visits ; 20 Apr 2011 7:29 PM
+1 ;;5.0;Radiology/Nuclear Medicine;**10,17,21,26,41,57,56,1003**;Nov 01, 2010;Build 3
+2 ;Supported IA #2053 FILE^DIE
+3 ;Supported IA #4663 SWSTAT^IBBAPI
+4 ;Controlled IA #1889 DATA2PCE^PXAPI
+5 QUIT
COMPLETE(RADFN,RADTI,RACNI) ; When an exam status changes to 'complete'
+1 ; Input: RADFN-> Patient DFN, RADTI-> Exam Timestamp, RACNI-> Case IEN
+2 ; NOTE: RACNI input param is ignored for exam sets (all cases under
+3 ; an exam set are processed at once when order is complete)
+4 ; $$DATA2PCE^PXAPI returns: 1 if no errors, else error condition
+5 ;
+6 KILL ^TMP("DIERR",$JOB),^TMP("RAPXAPI",$JOB)
+7 NEW RA7002,RA7003,RA71,RA791,RACNT,RADTE,RAEARRY,RAPKG,RAVSIT,RABAD,RASTAT,RACPTM,RA,RA1,RARECMPL,RACNISAV
+8 NEW RADUPRC,RACOMIEN,RASENT,RALCKFAL
+9 ; >0 if lock fails when :
SET RALCKFAL=0
+10 ; 1= complt'g exam that's unique to other cases same dt/tm, if any
+11 ; 2= complt'g exam that's a dupl of another cmplt'd exam (RESEND^RAPCE1)
+12 ; 3= UNcompleting exam before deleting credit+visit pointers same dt/tm
+13 SET RAPKG=$ORDER(^DIC(9.4,"B","RADIOLOGY/NUCLEAR MEDICINE",0))
+14 SET RADTE=9999999.9999-RADTI
SET RACNT=0
+15 SET RA7002=$GET(^RADPT(RADFN,"DT",RADTI,0))
+16 ; is this part of an exam set? 1=YES
SET RAXAMSET=+$PIECE(RA7002,"^",5)
EN2 SET RA791=$GET(^RA(79.1,+$PIECE(RA7002,"^",4),0))
+1 ; Initialize variables required for PFSS 1B project and check the switch status.
+2 ;IHS/BJI/DAY - Patch 1003 - Comment out call to VA's IBB pkg - set variable
+3 ;N RAPFSW,RACCOUNT S RAPFSW=$$SWSTAT^IBBAPI ; Requirement 12
+4 NEW RAPFSW
SET RAPFSW=0
+5 ;End Patch
+6 ; no credit, quit
IF +$PIECE(RA791,"^",21)=2
QUIT
+7 SET RAEARRY="RAERROR"
NEW @RAEARRY
LON ; lock at P level
+1 LOCK +^RADPT(RADFN,"DT",RADTI,"P",RACNI):30
IF '$TEST
SET RALCKFAL=1
DO FAILBUL^RAPCE2(RADFN,RADTI,RACNI,$SELECT($GET(RADUZ):RADUZ,1:DUZ))
QUIT
+2 IF 'RAXAMSET
GOTO NONSET
+3 ; exam set, grab all the completed records!
+4 SET RACNISAV=RACNI
+5 SET RACNI=0
+6 FOR
SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI))
IF RACNI'>0!($GET(RABAD))
QUIT
Begin DoDot:1
+7 ;check code instead of name
SET RA7003=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
IF $PIECE($GET(^RA(72,+$PIECE(RA7003,U,3),0)),U,3)'=9
QUIT
+8 SET RACNT=RACNT+1
DO SETUP
IF $GET(RABAD)
QUIT
+9 IF '$DATA(^TMP("RAPXAPI",$JOB,"ENCOUNTER"))
DO ENC(RACNT)
+10 ; Ordering ICD Dx and related data.
DO DX^RABWPCE($PIECE(RA7003,U,11))
+11 DO PROC(RACNT)
+12 QUIT
End DoDot:1
+13 ;restore value so unlock would work 012601
SET RACNI=RACNISAV
+14 IF '$GET(RABAD)
IF $DATA(^TMP("RAPXAPI",$JOB))
DO PCE(RADFN,RADTI,RACNI)
+15 ;Missing data, send failure bulletin for ea case in set, don't attempt to send data to PCE
+16 IF $GET(RABAD)
IF '$DATA(ZTQUEUED)&('$DATA(RARECMPL))
WRITE !,"Unable to credit Exam set"
Begin DoDot:1
+17 SET RACNI=0
FOR
SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI))
IF RACNI'>0
QUIT
DO FAILBUL^RAPCE2(RADFN,RADTI,RACNI,$SELECT($GET(RADUZ):RADUZ,1:DUZ))
End DoDot:1
+18 GOTO KOUT
NONSET ; non-exam sets
+1 SET RA7003=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
+2 ; chk for duplicate procedure(s) non-examset
DO CKDUP^RAPCE1
+3 ; branch off to re-send rec(s) this dt/tm
IF $GET(RADUPRC)
DO RESEND^RAPCE1
GOTO KOUT
+4 SET RACNT=RACNT+1
+5 DO SETUP
+6 IF '$GET(RABAD)
DO ENC(RACNT)
IF '$GET(RABAD)
DO DX^RABWPCE($PIECE(RA7003,U,11))
IF '$GET(RABAD)
DO PROC(RACNT)
IF '$GET(RABAD)
DO PCE(RADFN,RADTI,RACNI)
+7 ;Missing data, send failure bulletin for single case, don't attempt to pass data to PCE
IF $GET(RABAD)
IF '$DATA(ZTQUEUED)&('$DATA(RARECMPL))
WRITE !,"Unable to credit exam"
DO FAILBUL^RAPCE2(RADFN,RADTI,RACNI,$SELECT($GET(RADUZ):RADUZ,1:DUZ))
+8 ;
KOUT KILL ^TMP("RAPXAPI",$JOB)
+1 LOCK -^RADPT(RADFN,"DT",RADTI,"P",RACNI)
+2 QUIT
ENC(X) ; Set up the '"RAPXAPI",$J,"ENCOUNTER"' nodes
+1 NEW RAIMGLOC,RA17,RARPTLOC
+2 SET RA17=+$PIECE(RA7003,U,17)
+3 SET RARPTLOC=$PIECE($GET(^RARPT(RA17,"BA")),U,1)
+4 SET RAIMGLOC=$PIECE($GET(^RA(79.1,+RARPTLOC,0)),"^")
+5 IF 'RAIMGLOC
SET RAIMGLOC=$PIECE($GET(^RA(79.1,+$PIECE(RA7002,"^",4),0)),"^")
+6 ; needs imaging location
IF RAIMGLOC=""
SET RABAD=1
QUIT
+7 SET ^TMP("RAPXAPI",$JOB,"ENCOUNTER",X,"PATIENT")=RADFN
+8 SET ^TMP("RAPXAPI",$JOB,"ENCOUNTER",X,"ENC D/T")=RADTE
+9 SET ^TMP("RAPXAPI",$JOB,"ENCOUNTER",X,"HOS LOC")=RAIMGLOC
+10 SET ^TMP("RAPXAPI",$JOB,"ENCOUNTER",X,"SERVICE CATEGORY")="X"
+11 SET ^TMP("RAPXAPI",$JOB,"ENCOUNTER",X,"ENCOUNTER TYPE")="A"
+12 QUIT
PCE(RADFN,RADTI,RACNI) ; Pass on the information to the PCE software
+1 ;IHS/BJI/DAY - Patch 1003 - Continue Chris Saddler 2003 patch
+2 ;Quit this section, and use IHS calls to PCC instead
+3 QUIT
+4 ;End Patch
+5 NEW RASULT
+6 ; If the PFSS switch is not active then do not pass RACCOUNT parameter to DATA2PCE call.
+7 IF 'RAPFSW
SET RASULT=$$DATA2PCE^PXAPI("^TMP(""RAPXAPI"",$J)",RAPKG,"RAD/NUC MED",.RAVSIT,"","","","",.@RAEARRY)
+8 ; If the PFSS switch is active then use RACCOUNT parameter in DATA2PCE call.
+9 IF RAPFSW
Begin DoDot:1
+10 ; PFSS Requirement 6, 11
+11 SET RASULT=$$DATA2PCE^PXAPI("^TMP(""RAPXAPI"",$J)",RAPKG,"RAD/NUC MED",.RAVSIT,"","","","",.@RAEARRY,.RACCOUNT)
+12 QUIT
End DoDot:1
+13 ;Visit file pointer, set 'Credit recorded' to yes.
IF (RASULT=1)!(RASULT=-1)
Begin DoDot:1
+14 IF '$DATA(ZTQUEUED)&('$DATA(RARECMPL))
WRITE !?5,"Visit credited.",!
+15 IF 'RAXAMSET
DO VISIT(RADFN,RADTI,RACNI,RAVSIT)
+16 ; only one exam, not a set
IF 'RAXAMSET
DO RECDCS(RADFN,RADTI,RACNI)
+17 ; set, update all exams!
IF RAXAMSET
DO MULCS(RADFN,RADTI)
+18 ; sent to PCE was okay
SET RASENT=1
+19 QUIT
End DoDot:1
+20 IF '$TEST
Begin DoDot:1
+21 NEW RAWHOERR
SET RAWHOERR=""
+22 IF '$DATA(ZTQUEUED)&('$DATA(RARECMPL))
WRITE !?5,$CHAR(7),"Unable to credit.",!
+23 IF '$GET(RAXAMSET)
DO FAILBUL^RAPCE2(RADFN,RADTI,RACNI,$SELECT($GET(RADUZ):RADUZ,1:DUZ))
+24 IF $GET(RAXAMSET)
Begin DoDot:2
+25 SET RACNI=0
FOR
SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI))
IF RACNI'>0
QUIT
DO FAILBUL^RAPCE2(RADFN,RADTI,RACNI,$SELECT($GET(RADUZ):RADUZ,1:DUZ))
+26 QUIT
End DoDot:2
+27 QUIT
End DoDot:1
+28 QUIT
MULCS(RADFN,RADTI) ; Update the 'Credit recorded' field and the Visit
+1 ;pointer for each case that is complete
+2 NEW RACNI
SET RACNI=0
+3 FOR
SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI))
IF RACNI'>0
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(^RA(72,+$PIECE($GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U,3),0)),U,3)'=9
QUIT
+5 DO RECDCS(RADFN,RADTI,RACNI)
+6 DO VISIT(RADFN,RADTI,RACNI,RAVSIT)
+7 QUIT
End DoDot:1
+8 QUIT
PROC(X) ; Set up the other '"RAPXAPI",$J,"PROCEDURE"' nodes for this case
+1 ; If same procedure repeated in exam set, add to qty of existing
+2 ; 'procedure' node. Else, if different provider, create new
+3 ; separate 'procedure' nodes
+4 NEW X1,X2,X3,RADUP
FOR X1=1:1:X
SET X2=$GET(^TMP("RAPXAPI",$JOB,"PROCEDURE",X1,"PROCEDURE"))
IF X2=$PIECE(RA71,"^",9)
IF ^("ENC PROVIDER")=$SELECT(RA7003(15)]"":RA7003(15),1:RA7003(12))
Begin DoDot:1
+5 SET ^TMP("RAPXAPI",$JOB,"PROCEDURE",X1,"QTY")=^("QTY")+1
+6 DO CPTMOD(X1)
+7 SET RADUP=1
+8 QUIT
End DoDot:1
QUIT
+9 IF $DATA(RADUP)
QUIT
+10 SET ^TMP("RAPXAPI",$JOB,"PROCEDURE",X,"QTY")=1
+11 SET ^TMP("RAPXAPI",$JOB,"PROCEDURE",X,"PROCEDURE")=$PIECE(RA71,"^",9)
+12 SET ^TMP("RAPXAPI",$JOB,"PROCEDURE",X,"NARRATIVE")=$PIECE(RA71,"^")
+13 ; Pri. Int Staff if exists, else Pri Int Resident
SET ^TMP("RAPXAPI",$JOB,"PROCEDURE",X,"ENC PROVIDER")=$SELECT(RA7003(15)]"":RA7003(15),1:RA7003(12))
+14 ; Requesting Physician.
SET ^TMP("RAPXAPI",$JOB,"PROCEDURE",X,"ORD PROVIDER")=RA7003(14)
+15 SET ^TMP("RAPXAPI",$JOB,"PROCEDURE",X,"EVENT D/T")=RADTE
+16 ; if the PFSS switch is active Get both Dept. Code and Account Reference Number (RACCOUNT)
+17 ;IHS/BJI/DAY - Patch 1003 - Comment out call to VA's IBB package
+18 ;I RAPFSW D GETDEPT^RABWIBB ; Requirement 9
+19 ;End Patch
+20 DO CPTMOD(X)
+21 ; Add Ordering ICD Dx to each Procedure.
DO PROCDX^RABWPCE(X)
+22 QUIT
RECDCS(RADFN,RADTI,RACNI) ; Set 'Clinic Stop Recorded' to yes
+1 ; (70.03, fld 23)
+2 NEW RAFDA
SET RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",23)="Y"
+3 DO FILE^DIE("K","RAFDA")
+4 QUIT
SETUP ; Setup examination data node information
+1 ; If no provider, or inactive CPT, fail
+2 SET RA7003=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
+3 ; Pri. Inter. Resident
SET RA7003(12)=$PIECE(RA7003,"^",12)
+4 ; Requesting Physician.
SET RA7003(14)=$PIECE(RA7003,"^",14)
+5 ; Pri. Inter. Staff
SET RA7003(15)=$PIECE(RA7003,"^",15)
+6 ; OK to send if missing resident/staff ONLY if report Elec. Filed
+7 IF (RA7003(12)="")&(RA7003(15)="")
IF $PIECE($GET(^RARPT(+$PIECE(RA7003,U,17),0)),U,5)'="EF"
SET RABAD=1
QUIT
+8 SET RA71=$GET(^RAMIS(71,+$PIECE(RA7003,"^",2),0))
+9 ; store CPT Modifiers' .01 value
+10 ;only valid cpt mods
KILL RACPTM
SET RA=0
FOR
SET RA=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",RA))
IF 'RA
QUIT
SET RA1=$$BASICMOD^RACPTMSC($PIECE($GET(^(RA,0)),"^"),+$PIECE(RA7002,"^"))
IF +RA1>0
SET RACPTM(RA)=$PIECE(RA1,"^",2)
+11 ; find out if CPT code is active
+12 IF '$$ACTCODE^RACPTMSC(+$PIECE(RA71,"^",9),$PIECE(RA7002,"^"))
SET RABAD=1
+13 QUIT
VISIT(RADFN,RADTI,RACNI,RAVSIT) ; Stuff the Visit file pointer passed back
+1 ; from $$DATA2PCE^PXAPI() into the Visit field (70.02, fld 6)
+2 NEW RAFDA
SET RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",27)=RAVSIT
+3 DO FILE^DIE("K","RAFDA")
+4 QUIT
CPTMOD(X3) ;CPT Modifiers
+1 ; CPT Mods for dupl. procedure+provider will be accounted for
+2 ; however, same CPT Mod will overwrite previous CPT Mod
+3 ;prevent abend
SET ^TMP("RAPXAPI",$JOB,"PROCEDURE",X3,"MODIFIERS")=""
+4 SET RA=0
+5 FOR
SET RA=$ORDER(RACPTM(RA))
IF 'RA
QUIT
SET ^TMP("RAPXAPI",$JOB,"PROCEDURE",X3,"MODIFIERS",RACPTM(RA))=""
+6 QUIT
