Routine: RAPCE

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

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)

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"

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

 ;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

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

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.

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")

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

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")

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))=""

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

RAPCE.m