RMPRPFFS ;Hines OIFO/HNC - REMOTE PROCEDURE, LIST NPPD DATA ;9/8/03 07:23
;;3.0;PROSTHETICS;**96,60,168**;Feb 09, 1996;Build 43
;
; Reference to $$SINFO^ICDEX supported by ICR #5747
; Reference to $$ICDDX^ICDEX supported by ICR #5747
;
; patch 96 - HNC
; ICR #4419 for INSUR^IBBAPI
; ICR #1997 for STATCHK^ICPTAPIU
; ICR #3823 for read file 355.3, field .04
;
;RESULTS passed to broker in ^TMP($J,
;delimited by "^"
;piece 1 = ENTRY DATE
;piece 2 = PATIENT NAME
;piece 3 = PSAS HCPCS with * if hcpcs has Calculation Flag
;piece 4 = QTY
;piece 5 = Insurance with * if more insurance info available
;piece 6 = Insurance Effective Date
;piece 7 = TOTAL COST
;piece 8 = DESCRIPTION (ITEM, BRIEF DESCRIPTION WITH ~R~ FOR REPAIR)
;piece 9 = Coding Errors
;piece 10 = Insurance Holder
;piece 11 = STATION
;piece 12 = ICD Description
;piece 13 = Billing Group Number
;piece 14 = Subscriber ID
;piece 15 = SSN
;piece 16 = IEN TO FILE 660
;piece 17 = HCPCS SHORT DESCRIPTION
;piece 18 = ICD Code ~ Coding System
;piece 19 = Delivery Date
;piece 20 = Expiration Insurance Date
;piece 21 = Hcpcs-Ic Flag, this routine will set field 4.9 in file 660
;all records will have a 1
;ICD, 2
;HCPCS, 3
;Not Billable 4
;
;No errors, number 1.
;PSAS HCPCS, Not Billable Item, number 14.
;ICD error, number 12.
;HCPCS error, number 13.
;Both ICD and HCPCS error, number 132.
;Both ICD error and Not Billable Item, number 142.
Q
;
EN(RESULT,DATE1,DATE2) ;broker entry point
;
K ^TMP($J)
I '$D(DATE1)!('$D(DATE2)) G EXIT
S DATE=DATE1-1
F S DATE=$O(^RMPR(660,"B",DATE)) Q:(DATE="")!($P(DATE,".",1)>DATE2) D
.S RMPRB=0
.F S RMPRB=$O(^RMPR(660,"B",DATE,RMPRB)) Q:RMPRB="" D
..Q:$P(^RMPR(660,RMPRB,0),U,15)["*"
..Q:$P(^RMPR(660,RMPRB,0),U,14)'["C"
..;Q:$P(^RMPR(660,RMPRB,0),U,12)=""
..Q:$P($G(^RMPR(660,RMPRB,"AM")),U,3)<2
..;end of filter
..S PHCPCS=$P($G(^RMPR(660,RMPRB,1)),U,4)
..Q:PHCPCS=""
..Q:PHCPCS'>0
..S HDES=$P(^RMPR(661.1,PHCPCS,0),U,2)
..;code set versioning check
..S RICP=""
..S RICP=$P(^RMPR(661.1,PHCPCS,0),U,1)
..S RICPP="",CODERR="Alert",CODEFLG=1
..I RICP'="" D
...I $A($E(RICP,2,2))>64 S CODERR=" Non Billable Item",CODEFLG=CODEFLG_4 Q
...I $A($E(RICP,2,2))<65 S RICPP=$$STATCHK^ICPTAPIU(RICP,$P(^RMPR(660,RMPRB,0),U,1))
..I RICPP'="" D
...I $P(RICPP,U,1)=0 S CODERR=CODERR_" HCPCS Inactive",CODEFLG=CODEFLG_3
..S TYPE=$P($G(^RMPR(660,RMPRB,0)),U,4)
..I TYPE'="X" S LINE=$P(^RMPR(661.1,PHCPCS,0),U,7)
..I TYPE="X" S LINE=$P(^RMPR(661.1,PHCPCS,0),U,6)
..S CAL=$P(^RMPR(661.1,PHCPCS,0),U,8)
..I CAL'="" S CAL="*"
..S DFN=$P(^RMPR(660,RMPRB,0),U,2)
..D DEM^VADPT
..D SVC^VADPT
..S RMPROEOI=$S(VASV(11)>0:"<!>",VASV(12)>0:"<!>",VASV(13)>0:"<!>",1:0)
..S (RMI,HOLDER,SUBID,INSUR,INSURE,INSURG,INSURGG,RMPRDELD,RMPRIND,RMPRDEL)=""
..S RMPRDELD=$P(^RMPR(660,RMPRB,0),U,12)
..I RMPRDELD'="" S RMPRDEL=$E(RMPRDELD,4,5)_"/"_$E(RMPRDELD,6,7)_"/"_(($E(RMPRDELD,1,3))+1700)
..S X=$$INSUR^IBBAPI(DFN,,"RBA",.RMI,"*") I $D(RMI) D
...;format the RMI array
...;look for primary insurance
...;RMI("IBBAPI","INSUR",n,7)=1^PRIMARY
...S X="" F S X=$O(RMI("IBBAPI","INSUR",X)) Q:'X D
....;I $P(RMI("IBBAPI","INSUR",X,7),U,2)'="PRIMARY" Q
....S INSUR=$P(RMI("IBBAPI","INSUR",X,1),U,2)
....I X>1 S INSUR="*"_INSUR
....S SUBID=$P(RMI("IBBAPI","INSUR",X,14),U,1)
....S HOLDER=$P(RMI("IBBAPI","INSUR",X,12),U,2)
....S RMPRIND=$P(RMI("IBBAPI","INSUR",X,11),U,1)
....I RMPRIND'="" S RMPRIND=$E(RMPRIND,4,5)_"/"_$E(RMPRIND,6,7)_"/"_(($E(RMPRIND,1,3))+1700)
....S INSURE=$P(RMI("IBBAPI","INSUR",X,10),U,1)
....I INSURE'="" S INSURE=$E(INSURE,4,5)_"/"_$E(INSURE,6,7)_"/"_(($E(INSURE,1,3))+1700)
....S INSURG=$P(RMI("IBBAPI","INSUR",X,8),U,1)
....S INSURGG=$$GET1^DIQ(355.3,INSURG_",",.04)
..I '$D(RMI) D
...S INSUR="No Insurance Information"
...S SUBID=""
...S HOLDER=""
...S INSURE=""
...S INSURGG=""
...S RMPRIND=""
..;
..; ICD10 Changes - Add the Coding System as the 2nd ~ delimited piece
..N RMPRACS,RMPRACSI,RMPRCSI,RMPRICDD,RMPRICDE,RMPRSICD
..S (RMPRACS,RMPRACSI,RMPRCSI,RMPRICDD,RMPRICDE,RMPRSICD)=""
..; Get ICD data
..S RMPRSICD=$P($G(^RMPR(660,RMPRB,10)),U,8) ; SUSPENSE ICD (#8.8)
..I RMPRSICD'="" D
...; Determine Active Coding System Information
...S RMPRCSI=$$SINFO^ICDEX("DIAG",DATE) ; Supported by ICR 5747
...S RMPRACSI=$P(RMPRCSI,U,1) ; Internal format Active Coding System based on Date of Interest
...S RMPRACS=$P(RMPRCSI,U,2) ; External format Active Coding System based on Date of Interest
...; Retrieve ICD Data
...S RMPRSICD=$$ICDDX^ICDEX(RMPRSICD,DATE,RMPRACSI,"I") ; Supported by ICR 5747
...I RMPRSICD'="" S RMPRICDE=$P(RMPRSICD,U,2),RMPRICDD=$P(RMPRSICD,U,4)
...S RMPRACS=$S(RMPRACS="ICD-9-CM":9,RMPRACS="ICD-10-CM":10,1:"")
...I RMPRSICD'="" S RMPRICDE=$P(RMPRSICD,U,2)_"~"_+RMPRACS
...; Check STATUS (#66) from File #80.
...I $P(RMPRSICD,U,10)=0 S CODERR=CODERR_" ICD"_RMPRACS_" Inactive",CODEFLG=CODEFLG_2
..D DATA
S RESULT=$NA(^TMP($J))
Q
;
DATA ;
S B=RMPRB
D GETS^DIQ(660,B,".01;.02;2;4.5;5;7;8;8.3;11;12;14;24;27;68","","RMXM")
S $P(^TMP($J,B),U,1)=$G(RMXM(660,B_",",.01))
;Check for OEF/OIF
I RMPROEOI="<!>" S RMXM(660,B_",",.02)="<!>"_RMXM(660,B_",",.02)
S $P(^TMP($J,B),U,2)=$G(RMXM(660,B_",",.02))
S $P(^TMP($J,B),U,3)=$G(RMXM(660,B_",",4.5))_CAL
S $P(^TMP($J,B),U,4)=$G(RMXM(660,B_",",5))
;change to insurance
I INSUR="" S INSUR="Incomplete Insurance Information"
S $P(^TMP($J,B),U,5)=INSUR
;change to effective insurance date
S $P(^TMP($J,B),U,6)=INSURE
S $P(^TMP($J,B),U,7)=$G(RMXM(660,B_",",14))
;patch 77 remove the " for Excel CSV
;append ~R~ for repair items
I $G(RMXM(660,B_",",2))="REPAIR" S RMXM(660,B_",",24)="~R~"_RMXM(660,B_",",24)
S $P(^TMP($J,B),U,8)=$TR($G(RMXM(660,B_",",24)),"""","'")
;change to coding errors
I CODERR="Alert" S CODERR=""
S $P(^TMP($J,B),U,9)=CODERR
;change to holder
S $P(^TMP($J,B),U,10)=HOLDER
S $P(^TMP($J,B),U,11)=$G(RMXM(660,B_",",8))
;change to ICD description
S $P(^TMP($J,B),U,12)=RMPRICDD
;change to Billing Group
S $P(^TMP($J,B),U,13)=INSURGG
;change to subscriber ID
S $P(^TMP($J,B),U,14)=SUBID
S $P(^TMP($J,B),U,15)=$P(VADM(2),U,2)
S $P(^TMP($J,B),U,16)=B
S $P(^TMP($J,B),U,17)=HDES
;change to ICD code
S $P(^TMP($J,B),U,18)=RMPRICDE
;add Delivery Date
S $P(^TMP($J,B),U,20)=RMPRDEL
;add Insurance Expiration Date
S $P(^TMP($J,B),U,19)=RMPRIND
;hcpcs-icd code flag
S $P(^TMP($J,B),U,21)=CODEFLG
S $P(^RMPR(660,RMPRB,1),U,11)=CODEFLG
S $P(^RMPR(660,RMPRB,1),U,12)=DT
K RMXM,VADM,CAL
D KVAR^VADPT
Q
EXIT ;common exit point
N RESULTS D KILL^XUSCLEAN
Q
;END
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPFFS 6790 printed Sep 23, 2025@20:12:04 Page 2
RMPRPFFS ;Hines OIFO/HNC - REMOTE PROCEDURE, LIST NPPD DATA ;9/8/03 07:23
+1 ;;3.0;PROSTHETICS;**96,60,168**;Feb 09, 1996;Build 43
+2 ;
+3 ; Reference to $$SINFO^ICDEX supported by ICR #5747
+4 ; Reference to $$ICDDX^ICDEX supported by ICR #5747
+5 ;
+6 ; patch 96 - HNC
+7 ; ICR #4419 for INSUR^IBBAPI
+8 ; ICR #1997 for STATCHK^ICPTAPIU
+9 ; ICR #3823 for read file 355.3, field .04
+10 ;
+11 ;RESULTS passed to broker in ^TMP($J,
+12 ;delimited by "^"
+13 ;piece 1 = ENTRY DATE
+14 ;piece 2 = PATIENT NAME
+15 ;piece 3 = PSAS HCPCS with * if hcpcs has Calculation Flag
+16 ;piece 4 = QTY
+17 ;piece 5 = Insurance with * if more insurance info available
+18 ;piece 6 = Insurance Effective Date
+19 ;piece 7 = TOTAL COST
+20 ;piece 8 = DESCRIPTION (ITEM, BRIEF DESCRIPTION WITH ~R~ FOR REPAIR)
+21 ;piece 9 = Coding Errors
+22 ;piece 10 = Insurance Holder
+23 ;piece 11 = STATION
+24 ;piece 12 = ICD Description
+25 ;piece 13 = Billing Group Number
+26 ;piece 14 = Subscriber ID
+27 ;piece 15 = SSN
+28 ;piece 16 = IEN TO FILE 660
+29 ;piece 17 = HCPCS SHORT DESCRIPTION
+30 ;piece 18 = ICD Code ~ Coding System
+31 ;piece 19 = Delivery Date
+32 ;piece 20 = Expiration Insurance Date
+33 ;piece 21 = Hcpcs-Ic Flag, this routine will set field 4.9 in file 660
+34 ;all records will have a 1
+35 ;ICD, 2
+36 ;HCPCS, 3
+37 ;Not Billable 4
+38 ;
+39 ;No errors, number 1.
+40 ;PSAS HCPCS, Not Billable Item, number 14.
+41 ;ICD error, number 12.
+42 ;HCPCS error, number 13.
+43 ;Both ICD and HCPCS error, number 132.
+44 ;Both ICD error and Not Billable Item, number 142.
+45 QUIT
+46 ;
EN(RESULT,DATE1,DATE2) ;broker entry point
+1 ;
+2 KILL ^TMP($JOB)
+3 IF '$DATA(DATE1)!('$DATA(DATE2))
GOTO EXIT
+4 SET DATE=DATE1-1
+5 FOR
SET DATE=$ORDER(^RMPR(660,"B",DATE))
if (DATE="")!($PIECE(DATE,".",1)>DATE2)
QUIT
Begin DoDot:1
+6 SET RMPRB=0
+7 FOR
SET RMPRB=$ORDER(^RMPR(660,"B",DATE,RMPRB))
if RMPRB=""
QUIT
Begin DoDot:2
+8 if $PIECE(^RMPR(660,RMPRB,0),U,15)["*"
QUIT
+9 if $PIECE(^RMPR(660,RMPRB,0),U,14)'["C"
QUIT
+10 ;Q:$P(^RMPR(660,RMPRB,0),U,12)=""
+11 if $PIECE($GET(^RMPR(660,RMPRB,"AM")),U,3)<2
QUIT
+12 ;end of filter
+13 SET PHCPCS=$PIECE($GET(^RMPR(660,RMPRB,1)),U,4)
+14 if PHCPCS=""
QUIT
+15 if PHCPCS'>0
QUIT
+16 SET HDES=$PIECE(^RMPR(661.1,PHCPCS,0),U,2)
+17 ;code set versioning check
+18 SET RICP=""
+19 SET RICP=$PIECE(^RMPR(661.1,PHCPCS,0),U,1)
+20 SET RICPP=""
SET CODERR="Alert"
SET CODEFLG=1
+21 IF RICP'=""
Begin DoDot:3
+22 IF $ASCII($EXTRACT(RICP,2,2))>64
SET CODERR=" Non Billable Item"
SET CODEFLG=CODEFLG_4
QUIT
+23 IF $ASCII($EXTRACT(RICP,2,2))<65
SET RICPP=$$STATCHK^ICPTAPIU(RICP,$PIECE(^RMPR(660,RMPRB,0),U,1))
End DoDot:3
+24 IF RICPP'=""
Begin DoDot:3
+25 IF $PIECE(RICPP,U,1)=0
SET CODERR=CODERR_" HCPCS Inactive"
SET CODEFLG=CODEFLG_3
End DoDot:3
+26 SET TYPE=$PIECE($GET(^RMPR(660,RMPRB,0)),U,4)
+27 IF TYPE'="X"
SET LINE=$PIECE(^RMPR(661.1,PHCPCS,0),U,7)
+28 IF TYPE="X"
SET LINE=$PIECE(^RMPR(661.1,PHCPCS,0),U,6)
+29 SET CAL=$PIECE(^RMPR(661.1,PHCPCS,0),U,8)
+30 IF CAL'=""
SET CAL="*"
+31 SET DFN=$PIECE(^RMPR(660,RMPRB,0),U,2)
+32 DO DEM^VADPT
+33 DO SVC^VADPT
+34 SET RMPROEOI=$SELECT(VASV(11)>0:"<!>",VASV(12)>0:"<!>",VASV(13)>0:"<!>",1:0)
+35 SET (RMI,HOLDER,SUBID,INSUR,INSURE,INSURG,INSURGG,RMPRDELD,RMPRIND,RMPRDEL)=""
+36 SET RMPRDELD=$PIECE(^RMPR(660,RMPRB,0),U,12)
+37 IF RMPRDELD'=""
SET RMPRDEL=$EXTRACT(RMPRDELD,4,5)_"/"_$EXTRACT(RMPRDELD,6,7)_"/"_(($EXTRACT(RMPRDELD,1,3))+1700)
+38 SET X=$$INSUR^IBBAPI(DFN,,"RBA",.RMI,"*")
IF $DATA(RMI)
Begin DoDot:3
+39 ;format the RMI array
+40 ;look for primary insurance
+41 ;RMI("IBBAPI","INSUR",n,7)=1^PRIMARY
+42 SET X=""
FOR
SET X=$ORDER(RMI("IBBAPI","INSUR",X))
if 'X
QUIT
Begin DoDot:4
+43 ;I $P(RMI("IBBAPI","INSUR",X,7),U,2)'="PRIMARY" Q
+44 SET INSUR=$PIECE(RMI("IBBAPI","INSUR",X,1),U,2)
+45 IF X>1
SET INSUR="*"_INSUR
+46 SET SUBID=$PIECE(RMI("IBBAPI","INSUR",X,14),U,1)
+47 SET HOLDER=$PIECE(RMI("IBBAPI","INSUR",X,12),U,2)
+48 SET RMPRIND=$PIECE(RMI("IBBAPI","INSUR",X,11),U,1)
+49 IF RMPRIND'=""
SET RMPRIND=$EXTRACT(RMPRIND,4,5)_"/"_$EXTRACT(RMPRIND,6,7)_"/"_(($EXTRACT(RMPRIND,1,3))+1700)
+50 SET INSURE=$PIECE(RMI("IBBAPI","INSUR",X,10),U,1)
+51 IF INSURE'=""
SET INSURE=$EXTRACT(INSURE,4,5)_"/"_$EXTRACT(INSURE,6,7)_"/"_(($EXTRACT(INSURE,1,3))+1700)
+52 SET INSURG=$PIECE(RMI("IBBAPI","INSUR",X,8),U,1)
+53 SET INSURGG=$$GET1^DIQ(355.3,INSURG_",",.04)
End DoDot:4
End DoDot:3
+54 IF '$DATA(RMI)
Begin DoDot:3
+55 SET INSUR="No Insurance Information"
+56 SET SUBID=""
+57 SET HOLDER=""
+58 SET INSURE=""
+59 SET INSURGG=""
+60 SET RMPRIND=""
End DoDot:3
+61 ;
+62 ; ICD10 Changes - Add the Coding System as the 2nd ~ delimited piece
+63 NEW RMPRACS,RMPRACSI,RMPRCSI,RMPRICDD,RMPRICDE,RMPRSICD
+64 SET (RMPRACS,RMPRACSI,RMPRCSI,RMPRICDD,RMPRICDE,RMPRSICD)=""
+65 ; Get ICD data
+66 ; SUSPENSE ICD (#8.8)
SET RMPRSICD=$PIECE($GET(^RMPR(660,RMPRB,10)),U,8)
+67 IF RMPRSICD'=""
Begin DoDot:3
+68 ; Determine Active Coding System Information
+69 ; Supported by ICR 5747
SET RMPRCSI=$$SINFO^ICDEX("DIAG",DATE)
+70 ; Internal format Active Coding System based on Date of Interest
SET RMPRACSI=$PIECE(RMPRCSI,U,1)
+71 ; External format Active Coding System based on Date of Interest
SET RMPRACS=$PIECE(RMPRCSI,U,2)
+72 ; Retrieve ICD Data
+73 ; Supported by ICR 5747
SET RMPRSICD=$$ICDDX^ICDEX(RMPRSICD,DATE,RMPRACSI,"I")
+74 IF RMPRSICD'=""
SET RMPRICDE=$PIECE(RMPRSICD,U,2)
SET RMPRICDD=$PIECE(RMPRSICD,U,4)
+75 SET RMPRACS=$SELECT(RMPRACS="ICD-9-CM":9,RMPRACS="ICD-10-CM":10,1:"")
+76 IF RMPRSICD'=""
SET RMPRICDE=$PIECE(RMPRSICD,U,2)_"~"_+RMPRACS
+77 ; Check STATUS (#66) from File #80.
+78 IF $PIECE(RMPRSICD,U,10)=0
SET CODERR=CODERR_" ICD"_RMPRACS_" Inactive"
SET CODEFLG=CODEFLG_2
End DoDot:3
+79 DO DATA
End DoDot:2
End DoDot:1
+80 SET RESULT=$NAME(^TMP($JOB))
+81 QUIT
+82 ;
DATA ;
+1 SET B=RMPRB
+2 DO GETS^DIQ(660,B,".01;.02;2;4.5;5;7;8;8.3;11;12;14;24;27;68","","RMXM")
+3 SET $PIECE(^TMP($JOB,B),U,1)=$GET(RMXM(660,B_",",.01))
+4 ;Check for OEF/OIF
+5 IF RMPROEOI="<!>"
SET RMXM(660,B_",",.02)="<!>"_RMXM(660,B_",",.02)
+6 SET $PIECE(^TMP($JOB,B),U,2)=$GET(RMXM(660,B_",",.02))
+7 SET $PIECE(^TMP($JOB,B),U,3)=$GET(RMXM(660,B_",",4.5))_CAL
+8 SET $PIECE(^TMP($JOB,B),U,4)=$GET(RMXM(660,B_",",5))
+9 ;change to insurance
+10 IF INSUR=""
SET INSUR="Incomplete Insurance Information"
+11 SET $PIECE(^TMP($JOB,B),U,5)=INSUR
+12 ;change to effective insurance date
+13 SET $PIECE(^TMP($JOB,B),U,6)=INSURE
+14 SET $PIECE(^TMP($JOB,B),U,7)=$GET(RMXM(660,B_",",14))
+15 ;patch 77 remove the " for Excel CSV
+16 ;append ~R~ for repair items
+17 IF $GET(RMXM(660,B_",",2))="REPAIR"
SET RMXM(660,B_",",24)="~R~"_RMXM(660,B_",",24)
+18 SET $PIECE(^TMP($JOB,B),U,8)=$TRANSLATE($GET(RMXM(660,B_",",24)),"""","'")
+19 ;change to coding errors
+20 IF CODERR="Alert"
SET CODERR=""
+21 SET $PIECE(^TMP($JOB,B),U,9)=CODERR
+22 ;change to holder
+23 SET $PIECE(^TMP($JOB,B),U,10)=HOLDER
+24 SET $PIECE(^TMP($JOB,B),U,11)=$GET(RMXM(660,B_",",8))
+25 ;change to ICD description
+26 SET $PIECE(^TMP($JOB,B),U,12)=RMPRICDD
+27 ;change to Billing Group
+28 SET $PIECE(^TMP($JOB,B),U,13)=INSURGG
+29 ;change to subscriber ID
+30 SET $PIECE(^TMP($JOB,B),U,14)=SUBID
+31 SET $PIECE(^TMP($JOB,B),U,15)=$PIECE(VADM(2),U,2)
+32 SET $PIECE(^TMP($JOB,B),U,16)=B
+33 SET $PIECE(^TMP($JOB,B),U,17)=HDES
+34 ;change to ICD code
+35 SET $PIECE(^TMP($JOB,B),U,18)=RMPRICDE
+36 ;add Delivery Date
+37 SET $PIECE(^TMP($JOB,B),U,20)=RMPRDEL
+38 ;add Insurance Expiration Date
+39 SET $PIECE(^TMP($JOB,B),U,19)=RMPRIND
+40 ;hcpcs-icd code flag
+41 SET $PIECE(^TMP($JOB,B),U,21)=CODEFLG
+42 SET $PIECE(^RMPR(660,RMPRB,1),U,11)=CODEFLG
+43 SET $PIECE(^RMPR(660,RMPRB,1),U,12)=DT
+44 KILL RMXM,VADM,CAL
+45 DO KVAR^VADPT
+46 QUIT
EXIT ;common exit point
+1 NEW RESULTS
DO KILL^XUSCLEAN
+2 QUIT
+3 ;END
