RAPCE ;HIRMFO/GJC - Interface with PCE APIs for wrkload, visits ; Apr 28, 2022@08:42:59
;;5.0;Radiology/Nuclear Medicine;**10,17,21,26,41,57,56,153,172,174,189**;Mar 16, 1998;Build 1
;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
;
;//P174 begin//
; if this is a study with an outside report with a
; REPORT STATUS of 'Electronically Filed' quit.
Q:$$OUTSIDE()=1
;//P174 end//
;
; 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
;TEST: Singles registered together - treat as examset.
;I '$G(RAXAMSET),$P(^RADPT(RADFN,"DT",RADTI,"P",0),U,4)>1 S RAXAMSET=1
;
;//P174 begin//
EN2 ;check i-loc's credit method quit if 'no credit'
S RA791=$G(^RA(79.1,+$P(RA7002,"^",4),0))
Q:+$P(RA791,"^",21)=2 ; no credit, quit
;//P174 end//
;
; Initialize variables required for PFSS 1B project and check the switch status.
N RAPFSW,RACCOUNT S RAPFSW=$$SWSTAT^IBBAPI ; Requirement 12
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
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
;KLM/p172 - PX211 adds new result values that create visits. We'll check for visit IEN instead.
I $G(RAVSIT)>0 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
. I $G(RASULT)=-2 D RSCRFLR^RAPCE1 Q ;p189/KLM - Resend to PCE (PX211 work around)
. 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")=$$FMADD^XLFDT(RADTE,0,0,0,RACNI) ;For unique entry in V CPT post PX*1.0*211
;KLM/p172 - Pass the radiologist as 'Primary' for the encounter.
S ^TMP("RAPXAPI",$J,"PROVIDER",X,"NAME")=$S(RA7003(15)]"":RA7003(15),1:RA7003(12)) ; Pri. Int Staff if exists, else Pri Int Resident
S ^TMP("RAPXAPI",$J,"PROVIDER",X,"PRIMARY")=X
; if the PFSS switch is active Get both Dept. Code and Account Reference Number (RACCOUNT)
I RAPFSW D GETDEPT^RABWIBB ; Requirement 9
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
;
OUTSIDE() ;is this study tied to an outside report?
; input: none (vars RADFN,RADTI,RACNI must exist)
;return: one if an outside report, else zero
; note: Dx code and intepreter cannot be entered
; w/o a report on file
Q:'$D(RADFN)#2!('$D(RADTI)#2)!('$D(RACNI)#2) 1
N RARPT,RAY3
S RAY3=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
;if no report maybe their exam status setup
;needs review? Continue through RAPCE.
S RARPT=$P(RAY3,U,17) Q:RARPT="" 0
S RARPT(0)=$G(^RARPT(RARPT,0))
;REPORT STATUS fld #5, 0;5
;DATE INITIAL OUTSIDE RPT ENTRY fld #18, 0;18
Q $S($P(RARPT(0),U,5)="EF"&($P(RARPT(0),U,18)>0):1,1:0)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAPCE 9846 printed Oct 16, 2024@18:39:04 Page 2
RAPCE ;HIRMFO/GJC - Interface with PCE APIs for wrkload, visits ; Apr 28, 2022@08:42:59
+1 ;;5.0;Radiology/Nuclear Medicine;**10,17,21,26,41,57,56,153,172,174,189**;Mar 16, 1998;Build 1
+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 ;
+4 ;//P174 begin//
+5 ; if this is a study with an outside report with a
+6 ; REPORT STATUS of 'Electronically Filed' quit.
+7 if $$OUTSIDE()=1
QUIT
+8 ;//P174 end//
+9 ;
+10 ; an exam set are processed at once when order is complete)
+11 ; $$DATA2PCE^PXAPI returns: 1 if no errors, else error condition
+12 ;
+13 KILL ^TMP("DIERR",$JOB),^TMP("RAPXAPI",$JOB)
+14 NEW RA7002,RA7003,RA71,RA791,RACNT,RADTE,RAEARRY,RAPKG,RAVSIT,RABAD,RASTAT,RACPTM,RA,RA1,RARECMPL,RACNISAV
+15 NEW RADUPRC,RACOMIEN,RASENT,RALCKFAL
+16 ; >0 if lock fails when :
SET RALCKFAL=0
+17 ; 1= complt'g exam that's unique to other cases same dt/tm, if any
+18 ; 2= complt'g exam that's a dupl of another cmplt'd exam (RESEND^RAPCE1)
+19 ; 3= UNcompleting exam before deleting credit+visit pointers same dt/tm
+20 SET RAPKG=$ORDER(^DIC(9.4,"B","RADIOLOGY/NUCLEAR MEDICINE",0))
+21 SET RADTE=9999999.9999-RADTI
SET RACNT=0
+22 SET RA7002=$GET(^RADPT(RADFN,"DT",RADTI,0))
+23 ; is this part of an exam set? 1=YES
SET RAXAMSET=+$PIECE(RA7002,"^",5)
+24 ;TEST: Singles registered together - treat as examset.
+25 ;I '$G(RAXAMSET),$P(^RADPT(RADFN,"DT",RADTI,"P",0),U,4)>1 S RAXAMSET=1
+26 ;
+27 ;//P174 begin//
EN2 ;check i-loc's credit method quit if 'no credit'
+1 SET RA791=$GET(^RA(79.1,+$PIECE(RA7002,"^",4),0))
+2 ; no credit, quit
if +$PIECE(RA791,"^",21)=2
QUIT
+3 ;//P174 end//
+4 ;
+5 ; Initialize variables required for PFSS 1B project and check the switch status.
+6 ; Requirement 12
NEW RAPFSW,RACCOUNT
SET RAPFSW=$$SWSTAT^IBBAPI
+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 NEW RASULT
+2 ; If the PFSS switch is not active then do not pass RACCOUNT parameter to DATA2PCE call.
+3 IF 'RAPFSW
SET RASULT=$$DATA2PCE^PXAPI("^TMP(""RAPXAPI"",$J)",RAPKG,"RAD/NUC MED",.RAVSIT,"","","","",.@RAEARRY)
+4 ; If the PFSS switch is active then use RACCOUNT parameter in DATA2PCE call.
+5 IF RAPFSW
Begin DoDot:1
+6 ; PFSS Requirement 6, 11
+7 SET RASULT=$$DATA2PCE^PXAPI("^TMP(""RAPXAPI"",$J)",RAPKG,"RAD/NUC MED",.RAVSIT,"","","","",.@RAEARRY,.RACCOUNT)
+8 QUIT
End DoDot:1
+9 ;KLM/p172 - PX211 adds new result values that create visits. We'll check for visit IEN instead.
+10 ;Visit file pointer, set 'Credit recorded' to yes.
IF $GET(RAVSIT)>0
Begin DoDot:1
+11 if '$DATA(ZTQUEUED)&('$DATA(RARECMPL))
WRITE !?5,"Visit credited.",!
+12 if 'RAXAMSET
DO VISIT(RADFN,RADTI,RACNI,RAVSIT)
+13 ; only one exam, not a set
if 'RAXAMSET
DO RECDCS(RADFN,RADTI,RACNI)
+14 ; set, update all exams!
if RAXAMSET
DO MULCS(RADFN,RADTI)
+15 ; sent to PCE was okay
SET RASENT=1
+16 QUIT
End DoDot:1
+17 IF '$TEST
Begin DoDot:1
+18 ;p189/KLM - Resend to PCE (PX211 work around)
IF $GET(RASULT)=-2
DO RSCRFLR^RAPCE1
QUIT
+19 NEW RAWHOERR
SET RAWHOERR=""
+20 if '$DATA(ZTQUEUED)&('$DATA(RARECMPL))
WRITE !?5,$CHAR(7),"Unable to credit.",!
+21 IF '$GET(RAXAMSET)
DO FAILBUL^RAPCE2(RADFN,RADTI,RACNI,$SELECT($GET(RADUZ):RADUZ,1:DUZ))
+22 IF $GET(RAXAMSET)
Begin DoDot:2
+23 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))
+24 QUIT
End DoDot:2
+25 QUIT
End DoDot:1
+26 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 ;For unique entry in V CPT post PX*1.0*211
SET ^TMP("RAPXAPI",$JOB,"PROCEDURE",X,"EVENT D/T")=$$FMADD^XLFDT(RADTE,0,0,0,RACNI)
+16 ;KLM/p172 - Pass the radiologist as 'Primary' for the encounter.
+17 ; Pri. Int Staff if exists, else Pri Int Resident
SET ^TMP("RAPXAPI",$JOB,"PROVIDER",X,"NAME")=$SELECT(RA7003(15)]"":RA7003(15),1:RA7003(12))
+18 SET ^TMP("RAPXAPI",$JOB,"PROVIDER",X,"PRIMARY")=X
+19 ; if the PFSS switch is active Get both Dept. Code and Account Reference Number (RACCOUNT)
+20 ; Requirement 9
IF RAPFSW
DO GETDEPT^RABWIBB
+21 DO CPTMOD(X)
+22 ; Add Ordering ICD Dx to each Procedure.
DO PROCDX^RABWPCE(X)
+23 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
+7 ;
OUTSIDE() ;is this study tied to an outside report?
+1 ; input: none (vars RADFN,RADTI,RACNI must exist)
+2 ;return: one if an outside report, else zero
+3 ; note: Dx code and intepreter cannot be entered
+4 ; w/o a report on file
+5 if '$DATA(RADFN)#2!('$DATA(RADTI)#2)!('$DATA(RACNI)#2)
QUIT 1
+6 NEW RARPT,RAY3
+7 SET RAY3=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
+8 ;if no report maybe their exam status setup
+9 ;needs review? Continue through RAPCE.
+10 SET RARPT=$PIECE(RAY3,U,17)
if RARPT=""
QUIT 0
+11 SET RARPT(0)=$GET(^RARPT(RARPT,0))
+12 ;REPORT STATUS fld #5, 0;5
+13 ;DATE INITIAL OUTSIDE RPT ENTRY fld #18, 0;18
+14 QUIT $SELECT($PIECE(RARPT(0),U,5)="EF"&($PIECE(RARPT(0),U,18)>0):1,1:0)
+15 ;
