RMPR9S4E ;HOIFO/SPS - GUI 2319 Extended Display Transaction screen 4 ;12/17/02 09:35
;;3.0;PROSTHETICS;**59,92,99,90,75,168**;Feb 09, 1996;Build 43
;
; Reference to $$SINFO^ICDEX supported by ICR #5747
; Reference to $$ICDDX^ICDEX supported by ICR #5747
;
; (IEN)=ien of file 660
;
;AAC Patch 92 08/04/04 - Code Set Versioning (CSV)
;
;display detailed record
A1(IEN) G A2
EN(RESULTS,IEN) ;Broker
A2 ;
I +IEN'>0 S RESULTS(0)="NOTHING TO REPORT" G EXIT
I '$D(^RMPR(660,IEN)) S RESULTS(0)="NOTHING TO REPORT" G EXIT
N DIC,DIQ,DR,DA,I,RMPRDFN,RMPRDOB,RMPRLA,RMPRNAM,RMPRSSN,RMPRV,RMPRDA,RV
S DIC=660,DIQ="R19",DR=".01:96",DIQ(0)="EN"
S (RMPRDA,DA)=(IEN)
D EN^DIQ1
S DIQ="R19",DR=72,DIQ(0)="I" D EN^DIQ1
;get vendor info
S DA=$P(^RMPR(660,RMPRDA,0),U,9)
I DA D
.S DIC=440,DIQ="RV",DR=".01:6",DIQ(0)="EN"
.S (RMPRV,DA)=$P(^RMPR(660,RMPRDA,0),U,9)
.D EN^DIQ1
;
;array defined for record in following format:
;R19(filenumber,ien,field,E)=external form of data
;RV(filenumber,ien,field,E)=external form of data
;example:
;R19(660,100,.01,"E")=APR 27, 1995
;R19(660,100,.02,"E")=NAME,PATIENT
;RV(440,131,.01,"E")=ORTHOTIC LAB
S RMPRDFN=$P(^RMPR(660,RMPRDA,0),U,2)
S RMPRNAM=$P(^DPT(RMPRDFN,0),U),RMPRSSN=$P(^(0),U,9),RMPRDOB=$P(^(0),U,3)
;
D HDR
; "TYPE OF FORM: ",
S RESULTS(5)=$G(R19(660,RMPRDA,11,"E"))
; "INITIATOR: ",
S RESULTS(6)=$G(R19(660,RMPRDA,27,"E"))
; "DATE: ",
S RESULTS(7)=$G(R19(660,RMPRDA,1,"E"))
; "DELIVER TO: ",
S RESULTS(8)=$G(R19(660,RMPRDA,25,"E"))
; "TYPE TRANS: ",
S RESULTS(9)=$G(R19(660,RMPRDA,2,"E"))
; "QTY: ",
S RESULTS(10)=$G(R19(660,RMPRDA,5,"E"))
; "INVENTORY POINT: "
S RESULTS(11)=$G(R19(660,RMPRDA,29,"E"))
; "SOURCE: ",
S RESULTS(12)=$G(R19(660,RMPRDA,12,"E"))
;vendor tracking number
S (RESULTS(13),RESULTS(14))=""
I $G(R19(660,RMPRDA,11,"E"))="VISA" D
.; "VENDOR TRACKING: ",
.S RESULTS(13)=$G(R19(660,RMPRDA,4.2,"E"))
.; "BANK AUTHORIZATION: ",
.S RESULTS(14)=$G(R19(660,RMPRDA,38.7,"E"))
; "VENDOR: ",
S RESULTS(15)=$G(R19(660,RMPRDA,7,"E"))
; VENDOR PHONE AND ADDRESS INFO
F I=16:1:20 S RESULTS(I)=""
I $D(RV) D
.; "VENDOR PHONE: and Address ",
.S RESULTS(16)=$G(RV(440,RMPRV,5,"E"))
.S RESULTS(17)=$G(RV(440,RMPRV,1,"E"))
.S RESULTS(18)=$G(RV(440,RMPRV,4.2,"E"))
.S RESULTS(19)=$G(RV(440,RMPRV,4.4,"E"))
.S RESULTS(20)=$G(RV(440,RMPRV,4.6,"E"))
; "DELIVERY DATE: "
S RESULTS(21)=$G(R19(660,RMPRDA,10,"E"))
; "TOTAL COST: "
S RESULTS(22)=0.00
I $G(R19(660,RMPRDA,14,"E"))'="" S RESULTS(22)="$"_$FN(R19(660,RMPRDA,14,"E"),"T",2)
I $G(R19(660,RMPRDA,14,"E"))="" S RESULTS(22)=$S($G(R19(660,RMPRDA,6,"E"))'="":"$"_$FN(R19(660,RMPRDA,6,"E"),"T",2),$G(R19(660,RMPRDA,48,"E"))'="":"$"_$FN(R19(660,RMPRDA,48,"E"),"T",2),1:"")
; "OBL: ",
S RESULTS(23)=$G(R19(660,RMPRDA,23,"E"))
;
;lab data
F I=24:1:32 S RESULTS(I)=""
I $D(^RMPR(660,RMPRDA,"LB")) D
.N DIC,DIQ,DR,L19,DA
.S (DA,RMPRLA)=$P(^RMPR(660,RMPRDA,"LB"),U,10)
.Q:DA=""
.S DIC=664.1,DIQ="L19",DR="15",DIQ(0)="E"
.D EN^DIQ1
.; "WORK ORDER: ",
.S RESULTS(24)=$G(R19(660,RMPRDA,71,"E"))
.I $P(^RMPR(660,RMPRDA,"AM"),U,2)=1 S RESULTS(24)=$G(R19(660,RMPRDA,72.5,"E"))
.I $P(^RMPR(660,RMPRDA,"LB"),U,14)=1 S RESULTS(24)=$G(R19(660,RMPRDA,72.5,"E"))
.; "RECEIVING STATION: ",
.S RESULTS(25)=$G(R19(660,RMPRDA,70,"E"))
.; "TECHNICIAN: ",
.S RESULTS(26)=$G(L19(664.1,RMPRLA,15,"E"))
.; "TOTAL LABOR HOURS: ",
.S RESULTS(27)=$G(R19(660,RMPRDA,45,"E"))
.; "TOTAL LABOR COST: ",
.S RESULTS(28)=$G(R19(660,RMPRDA,46,"E"))
.; "TOTAL MATERIAL COST: ",
.S RESULTS(29)=$G(R19(660,RMPRDA,47,"E"))
.; "TOTAL LAB COST: ",
.S RESULTS(30)=$G(R19(660,RMPRDA,48,"E"))
.; "COMPLETION DATE: ",
.S RESULTS(31)=$G(R19(660,RMPRDA,50,"E"))
.; "LAB REMARKS: ",
.S RESULTS(32)=$G(R19(660,RMPRDA,51,"E"))
; "REMARKS: ",
S RESULTS(33)=$G(R19(660,RMPRDA,16,"E"))
; "RETURN STATUS: ",
S RESULTS(34)=$G(R19(660,RMPRDA,17.5,"E"))
;
; CoreFLS Data used to be/and same as historical data
F I=35:1:42 S RESULTS(I)=""
I $G(R19(660,RMPRDA,15,"E"))["*" D
.;include records that have been merged
.; "COREFLS/HISTORICAL DATA",!
.Q:'$D(R19(660,RMPRDA,89))
.; "ITEM: ",
.S RESULTS(35)=$G(R19(660,RMPRDA,89,"E"))
.; "STATION: ",
.S RESULTS(36)=$G(R19(660,RMPRDA,90,"E"))
.; "VENDOR: ",
.S RESULTS(37)=$G(R19(660,RMPRDA,91,"E"))
.; " PHONE: ",
.S RESULTS(38)=$G(R19(660,RMPRDA,92,"E"))
.; " STREET
.S RESULTS(39)=$G(R19(660,RMPRDA,93,"E"))
.; CITY
.S RESULTS(40)=$G(R19(660,RMPRDA,94,"E"))
.; STATE
.S RESULTS(41)=$G(R19(660,RMPRDA,95,"E"))
.; ZIP
.S RESULTS(42)=$G(R19(660,RMPRDA,96,"E"))
;put in lab display here fields 45,46,47,48 and 51
;lab amis
F I=43:1:44 S RESULTS(I)=""
I $G(R19(660,RMPRDA,73,"E")) D
.; "ORTHOTICS LAB CODE: "
.S RESULTS(43)=$S($D(R19(660,RMPRDA,74,"E")):R19(660,RMPRDA,74,"E"),$D(R19(660,RMPRDA,75,"E")):R19(660,RMPRDA,75,"E"),1:"")
.; "RESTORATIONS LAB CODE: "
.S RESULTS(44)=$S($D(R19(660,RMPRDA,76,"E")):R19(660,RMPRDA,76,"E"),$D(R19(660,RMPRDA,77,"E")):R19(660,RMPRDA,77,"E"),1:"")
;purchasing and issue from stock amis
; "DISABILITY SERVED: ",
S RESULTS(45)=$G(R19(660,RMPRDA,62,"E"))
;appliance/item information
; "APPLIANCE: ",
;S RESULTS(46)=$G(R19(660,RMPRDA,4,"E"))
S RESULTS(46)=$G(R19(660,RMPRDA,89,"E"))
; "PSAS HCPCS: ",
S RESULTS(47)=$G(R19(660,RMPRDA,4.5,"E"))
; "PSAS HCPCS DESC.
S RESULTS(48)=""
I $P($G(^RMPR(660,RMPRDA,1)),U,4) S RESULTS(48)=$P($G(^RMPR(661.1,$P(^RMPR(660,RMPRDA,1),U,4),0)),U,2)
;
; Updates for ICD10 project
N RMPRACS,RMPRCSI,RMPRDATE,RMPRICD,RMPRLLEN,RMPRSICD,RMPRTXT
S (RMPRACS,RMPRCSI,RMPRDATE,RMPRICD,RMPRLLEN,RMPRSICD,RMPRTXT,RESULTS(49))="",RMPRERR=0
S RMPRDATE=$P(^RMPR(660,RMPRDA,0),U,1)
I $D(^RMPR(660,RMPRDA,10)) S RMPRSICD=$P(^RMPR(660,RMPRDA,10),U,8) ; SUSPENSE ICD (#8.8)
; Retrieve and process the Suspense ICD
I RMPRSICD'="" D
.S RMPRCSI=$$SINFO^ICDEX("DIAG",RMPRDATE) ; Supported by ICR 5747
.S RMPRACS=$P(RMPRCSI,U,1) ; Internal format Active Coding System based on Date of Interest
.; Retrieve ICD Code Data
.S RMPRICD=$$ICDDX^ICDEX(RMPRSICD,RMPRDATE,RMPRACS,"I") ; Supported by ICR 5747
.S RMPRERR=$P(RMPRICD,U,1)
.I RMPRERR<0 S RESULTS(49)=$P(RMPRICD,U,2)
.S RMPRACS=$P(RMPRCSI,U,2) ; External format Active Coding System based on Date of Interest
.S RMPRACS=$S(RMPRACS="ICD-9-CM":9,RMPRACS="ICD-10-CM":10,1:"") ; adjust for 2nd return piece
ZZ ;
I RMPRERR>0 D
.S RESULTS(49)=$P(RMPRICD,U,2)_" "
.; Return brief description
.S RESULTS(49)=RESULTS(49)_$S(RMPRACS=9:$E($P(RMPRICD,U,4),1,55),1:$P(RMPRICD,U,4))
.; Check for Inactive Status
.I $P(RMPRICD,U,10)'>0 D
..S RMPRTXT=" ** Inactive ** Date: "
..S Y=$P(RMPRICD,U,12) ; Inactive Date
..D DD^%DT
..S RMPRTXT=RMPRTXT_Y ; External format date
..S RESULTS(49)=RESULTS(49)_RMPRTXT Q
.; Add Coding System for ICD as 2nd ^ delimited piece
.S RESULTS(49)=RESULTS(49)_"^"_RMPRACS
;
; End Patch 92
; End of ICD10 Updates
;
; "CPT MODIFIER: ",
S RESULTS(50)=$G(R19(660,RMPRDA,38.1,"E"))
; "DESCRIPTION: ",
S RESULTS(51)=$G(R19(660,RMPRDA,24,"E"))
; ,"EXTENDED DESCRIPTION: ",!
N R28
I $D(R19(660,RMPRDA,28)) D
.;command part of new standards
.MERGE R28=R19(660,RMPRDA,28)
N CNT,LN
S LN=0,CNT=52
F S LN=$O(R28(LN)) Q:LN'>0 D
.S RESULTS(CNT)=R28(LN)
.S CNT=CNT+1
G EXIT
;
HDR ;display heading
S RESULTS(1)=RMPRNAM
; " SSN: "
S RESULTS(2)=$E(RMPRSSN,1,3)_"-"_$E(RMPRSSN,4,5)_"-"_$E(RMPRSSN,6,10)
S RESULTS(3)=$G(R19(660,RMPRDA,8,"E"))
; "DOB: "
S RESULTS(4)=$S(RMPRDOB:$E(RMPRDOB,4,5)_"-"_$E(RMPRDOB,6,7)_"-"_(1700+$E(RMPRDOB,1,3)),1:"Unknown")
Q
EXIT ;common exit point
I '$D(RESULTS) S RESULTS(0)="NOTHING TO REPORT"
K R19,RV,RMPRICC,RMPRERR,Y
Q
;end
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR9S4E 7859 printed Dec 13, 2024@02:33:48 Page 2
RMPR9S4E ;HOIFO/SPS - GUI 2319 Extended Display Transaction screen 4 ;12/17/02 09:35
+1 ;;3.0;PROSTHETICS;**59,92,99,90,75,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 ; (IEN)=ien of file 660
+7 ;
+8 ;AAC Patch 92 08/04/04 - Code Set Versioning (CSV)
+9 ;
+10 ;display detailed record
A1(IEN) GOTO A2
EN(RESULTS,IEN) ;Broker
A2 ;
+1 IF +IEN'>0
SET RESULTS(0)="NOTHING TO REPORT"
GOTO EXIT
+2 IF '$DATA(^RMPR(660,IEN))
SET RESULTS(0)="NOTHING TO REPORT"
GOTO EXIT
+3 NEW DIC,DIQ,DR,DA,I,RMPRDFN,RMPRDOB,RMPRLA,RMPRNAM,RMPRSSN,RMPRV,RMPRDA,RV
+4 SET DIC=660
SET DIQ="R19"
SET DR=".01:96"
SET DIQ(0)="EN"
+5 SET (RMPRDA,DA)=(IEN)
+6 DO EN^DIQ1
+7 SET DIQ="R19"
SET DR=72
SET DIQ(0)="I"
DO EN^DIQ1
+8 ;get vendor info
+9 SET DA=$PIECE(^RMPR(660,RMPRDA,0),U,9)
+10 IF DA
Begin DoDot:1
+11 SET DIC=440
SET DIQ="RV"
SET DR=".01:6"
SET DIQ(0)="EN"
+12 SET (RMPRV,DA)=$PIECE(^RMPR(660,RMPRDA,0),U,9)
+13 DO EN^DIQ1
End DoDot:1
+14 ;
+15 ;array defined for record in following format:
+16 ;R19(filenumber,ien,field,E)=external form of data
+17 ;RV(filenumber,ien,field,E)=external form of data
+18 ;example:
+19 ;R19(660,100,.01,"E")=APR 27, 1995
+20 ;R19(660,100,.02,"E")=NAME,PATIENT
+21 ;RV(440,131,.01,"E")=ORTHOTIC LAB
+22 SET RMPRDFN=$PIECE(^RMPR(660,RMPRDA,0),U,2)
+23 SET RMPRNAM=$PIECE(^DPT(RMPRDFN,0),U)
SET RMPRSSN=$PIECE(^(0),U,9)
SET RMPRDOB=$PIECE(^(0),U,3)
+24 ;
+25 DO HDR
+26 ; "TYPE OF FORM: ",
+27 SET RESULTS(5)=$GET(R19(660,RMPRDA,11,"E"))
+28 ; "INITIATOR: ",
+29 SET RESULTS(6)=$GET(R19(660,RMPRDA,27,"E"))
+30 ; "DATE: ",
+31 SET RESULTS(7)=$GET(R19(660,RMPRDA,1,"E"))
+32 ; "DELIVER TO: ",
+33 SET RESULTS(8)=$GET(R19(660,RMPRDA,25,"E"))
+34 ; "TYPE TRANS: ",
+35 SET RESULTS(9)=$GET(R19(660,RMPRDA,2,"E"))
+36 ; "QTY: ",
+37 SET RESULTS(10)=$GET(R19(660,RMPRDA,5,"E"))
+38 ; "INVENTORY POINT: "
+39 SET RESULTS(11)=$GET(R19(660,RMPRDA,29,"E"))
+40 ; "SOURCE: ",
+41 SET RESULTS(12)=$GET(R19(660,RMPRDA,12,"E"))
+42 ;vendor tracking number
+43 SET (RESULTS(13),RESULTS(14))=""
+44 IF $GET(R19(660,RMPRDA,11,"E"))="VISA"
Begin DoDot:1
+45 ; "VENDOR TRACKING: ",
+46 SET RESULTS(13)=$GET(R19(660,RMPRDA,4.2,"E"))
+47 ; "BANK AUTHORIZATION: ",
+48 SET RESULTS(14)=$GET(R19(660,RMPRDA,38.7,"E"))
End DoDot:1
+49 ; "VENDOR: ",
+50 SET RESULTS(15)=$GET(R19(660,RMPRDA,7,"E"))
+51 ; VENDOR PHONE AND ADDRESS INFO
+52 FOR I=16:1:20
SET RESULTS(I)=""
+53 IF $DATA(RV)
Begin DoDot:1
+54 ; "VENDOR PHONE: and Address ",
+55 SET RESULTS(16)=$GET(RV(440,RMPRV,5,"E"))
+56 SET RESULTS(17)=$GET(RV(440,RMPRV,1,"E"))
+57 SET RESULTS(18)=$GET(RV(440,RMPRV,4.2,"E"))
+58 SET RESULTS(19)=$GET(RV(440,RMPRV,4.4,"E"))
+59 SET RESULTS(20)=$GET(RV(440,RMPRV,4.6,"E"))
End DoDot:1
+60 ; "DELIVERY DATE: "
+61 SET RESULTS(21)=$GET(R19(660,RMPRDA,10,"E"))
+62 ; "TOTAL COST: "
+63 SET RESULTS(22)=0.00
+64 IF $GET(R19(660,RMPRDA,14,"E"))'=""
SET RESULTS(22)="$"_$FNUMBER(R19(660,RMPRDA,14,"E"),"T",2)
+65 IF $GET(R19(660,RMPRDA,14,"E"))=""
SET RESULTS(22)=$SELECT($GET(R19(660,RMPRDA,6,"E"))'="":"$"_$FNUMBER(R19(660,RMPRDA,6,"E"),"T",2),$GET(R19(660,RMPRDA,48,"E"))'="":"$"_$FNUMBER(R19(660,RMPRDA,48,"E"),"T",2),1:"")
+66 ; "OBL: ",
+67 SET RESULTS(23)=$GET(R19(660,RMPRDA,23,"E"))
+68 ;
+69 ;lab data
+70 FOR I=24:1:32
SET RESULTS(I)=""
+71 IF $DATA(^RMPR(660,RMPRDA,"LB"))
Begin DoDot:1
+72 NEW DIC,DIQ,DR,L19,DA
+73 SET (DA,RMPRLA)=$PIECE(^RMPR(660,RMPRDA,"LB"),U,10)
+74 if DA=""
QUIT
+75 SET DIC=664.1
SET DIQ="L19"
SET DR="15"
SET DIQ(0)="E"
+76 DO EN^DIQ1
+77 ; "WORK ORDER: ",
+78 SET RESULTS(24)=$GET(R19(660,RMPRDA,71,"E"))
+79 IF $PIECE(^RMPR(660,RMPRDA,"AM"),U,2)=1
SET RESULTS(24)=$GET(R19(660,RMPRDA,72.5,"E"))
+80 IF $PIECE(^RMPR(660,RMPRDA,"LB"),U,14)=1
SET RESULTS(24)=$GET(R19(660,RMPRDA,72.5,"E"))
+81 ; "RECEIVING STATION: ",
+82 SET RESULTS(25)=$GET(R19(660,RMPRDA,70,"E"))
+83 ; "TECHNICIAN: ",
+84 SET RESULTS(26)=$GET(L19(664.1,RMPRLA,15,"E"))
+85 ; "TOTAL LABOR HOURS: ",
+86 SET RESULTS(27)=$GET(R19(660,RMPRDA,45,"E"))
+87 ; "TOTAL LABOR COST: ",
+88 SET RESULTS(28)=$GET(R19(660,RMPRDA,46,"E"))
+89 ; "TOTAL MATERIAL COST: ",
+90 SET RESULTS(29)=$GET(R19(660,RMPRDA,47,"E"))
+91 ; "TOTAL LAB COST: ",
+92 SET RESULTS(30)=$GET(R19(660,RMPRDA,48,"E"))
+93 ; "COMPLETION DATE: ",
+94 SET RESULTS(31)=$GET(R19(660,RMPRDA,50,"E"))
+95 ; "LAB REMARKS: ",
+96 SET RESULTS(32)=$GET(R19(660,RMPRDA,51,"E"))
End DoDot:1
+97 ; "REMARKS: ",
+98 SET RESULTS(33)=$GET(R19(660,RMPRDA,16,"E"))
+99 ; "RETURN STATUS: ",
+100 SET RESULTS(34)=$GET(R19(660,RMPRDA,17.5,"E"))
+101 ;
+102 ; CoreFLS Data used to be/and same as historical data
+103 FOR I=35:1:42
SET RESULTS(I)=""
+104 IF $GET(R19(660,RMPRDA,15,"E"))["*"
Begin DoDot:1
+105 ;include records that have been merged
+106 ; "COREFLS/HISTORICAL DATA",!
+107 if '$DATA(R19(660,RMPRDA,89))
QUIT
+108 ; "ITEM: ",
+109 SET RESULTS(35)=$GET(R19(660,RMPRDA,89,"E"))
+110 ; "STATION: ",
+111 SET RESULTS(36)=$GET(R19(660,RMPRDA,90,"E"))
+112 ; "VENDOR: ",
+113 SET RESULTS(37)=$GET(R19(660,RMPRDA,91,"E"))
+114 ; " PHONE: ",
+115 SET RESULTS(38)=$GET(R19(660,RMPRDA,92,"E"))
+116 ; " STREET
+117 SET RESULTS(39)=$GET(R19(660,RMPRDA,93,"E"))
+118 ; CITY
+119 SET RESULTS(40)=$GET(R19(660,RMPRDA,94,"E"))
+120 ; STATE
+121 SET RESULTS(41)=$GET(R19(660,RMPRDA,95,"E"))
+122 ; ZIP
+123 SET RESULTS(42)=$GET(R19(660,RMPRDA,96,"E"))
End DoDot:1
+124 ;put in lab display here fields 45,46,47,48 and 51
+125 ;lab amis
+126 FOR I=43:1:44
SET RESULTS(I)=""
+127 IF $GET(R19(660,RMPRDA,73,"E"))
Begin DoDot:1
+128 ; "ORTHOTICS LAB CODE: "
+129 SET RESULTS(43)=$SELECT($DATA(R19(660,RMPRDA,74,"E")):R19(660,RMPRDA,74,"E"),$DATA(R19(660,RMPRDA,75,"E")):R19(660,RMPRDA,75,"E"),1:"")
+130 ; "RESTORATIONS LAB CODE: "
+131 SET RESULTS(44)=$SELECT($DATA(R19(660,RMPRDA,76,"E")):R19(660,RMPRDA,76,"E"),$DATA(R19(660,RMPRDA,77,"E")):R19(660,RMPRDA,77,"E"),1:"")
End DoDot:1
+132 ;purchasing and issue from stock amis
+133 ; "DISABILITY SERVED: ",
+134 SET RESULTS(45)=$GET(R19(660,RMPRDA,62,"E"))
+135 ;appliance/item information
+136 ; "APPLIANCE: ",
+137 ;S RESULTS(46)=$G(R19(660,RMPRDA,4,"E"))
+138 SET RESULTS(46)=$GET(R19(660,RMPRDA,89,"E"))
+139 ; "PSAS HCPCS: ",
+140 SET RESULTS(47)=$GET(R19(660,RMPRDA,4.5,"E"))
+141 ; "PSAS HCPCS DESC.
+142 SET RESULTS(48)=""
+143 IF $PIECE($GET(^RMPR(660,RMPRDA,1)),U,4)
SET RESULTS(48)=$PIECE($GET(^RMPR(661.1,$PIECE(^RMPR(660,RMPRDA,1),U,4),0)),U,2)
+144 ;
+145 ; Updates for ICD10 project
+146 NEW RMPRACS,RMPRCSI,RMPRDATE,RMPRICD,RMPRLLEN,RMPRSICD,RMPRTXT
+147 SET (RMPRACS,RMPRCSI,RMPRDATE,RMPRICD,RMPRLLEN,RMPRSICD,RMPRTXT,RESULTS(49))=""
SET RMPRERR=0
+148 SET RMPRDATE=$PIECE(^RMPR(660,RMPRDA,0),U,1)
+149 ; SUSPENSE ICD (#8.8)
IF $DATA(^RMPR(660,RMPRDA,10))
SET RMPRSICD=$PIECE(^RMPR(660,RMPRDA,10),U,8)
+150 ; Retrieve and process the Suspense ICD
+151 IF RMPRSICD'=""
Begin DoDot:1
+152 ; Supported by ICR 5747
SET RMPRCSI=$$SINFO^ICDEX("DIAG",RMPRDATE)
+153 ; Internal format Active Coding System based on Date of Interest
SET RMPRACS=$PIECE(RMPRCSI,U,1)
+154 ; Retrieve ICD Code Data
+155 ; Supported by ICR 5747
SET RMPRICD=$$ICDDX^ICDEX(RMPRSICD,RMPRDATE,RMPRACS,"I")
+156 SET RMPRERR=$PIECE(RMPRICD,U,1)
+157 IF RMPRERR<0
SET RESULTS(49)=$PIECE(RMPRICD,U,2)
+158 ; External format Active Coding System based on Date of Interest
SET RMPRACS=$PIECE(RMPRCSI,U,2)
+159 ; adjust for 2nd return piece
SET RMPRACS=$SELECT(RMPRACS="ICD-9-CM":9,RMPRACS="ICD-10-CM":10,1:"")
End DoDot:1
ZZ ;
+1 IF RMPRERR>0
Begin DoDot:1
+2 SET RESULTS(49)=$PIECE(RMPRICD,U,2)_" "
+3 ; Return brief description
+4 SET RESULTS(49)=RESULTS(49)_$SELECT(RMPRACS=9:$EXTRACT($PIECE(RMPRICD,U,4),1,55),1:$PIECE(RMPRICD,U,4))
+5 ; Check for Inactive Status
+6 IF $PIECE(RMPRICD,U,10)'>0
Begin DoDot:2
+7 SET RMPRTXT=" ** Inactive ** Date: "
+8 ; Inactive Date
SET Y=$PIECE(RMPRICD,U,12)
+9 DO DD^%DT
+10 ; External format date
SET RMPRTXT=RMPRTXT_Y
+11 SET RESULTS(49)=RESULTS(49)_RMPRTXT
QUIT
End DoDot:2
+12 ; Add Coding System for ICD as 2nd ^ delimited piece
+13 SET RESULTS(49)=RESULTS(49)_"^"_RMPRACS
End DoDot:1
+14 ;
+15 ; End Patch 92
+16 ; End of ICD10 Updates
+17 ;
+18 ; "CPT MODIFIER: ",
+19 SET RESULTS(50)=$GET(R19(660,RMPRDA,38.1,"E"))
+20 ; "DESCRIPTION: ",
+21 SET RESULTS(51)=$GET(R19(660,RMPRDA,24,"E"))
+22 ; ,"EXTENDED DESCRIPTION: ",!
+23 NEW R28
+24 IF $DATA(R19(660,RMPRDA,28))
Begin DoDot:1
+25 ;command part of new standards
+26 MERGE R28=R19(660,RMPRDA,28)
End DoDot:1
+27 NEW CNT,LN
+28 SET LN=0
SET CNT=52
+29 FOR
SET LN=$ORDER(R28(LN))
if LN'>0
QUIT
Begin DoDot:1
+30 SET RESULTS(CNT)=R28(LN)
+31 SET CNT=CNT+1
End DoDot:1
+32 GOTO EXIT
+33 ;
HDR ;display heading
+1 SET RESULTS(1)=RMPRNAM
+2 ; " SSN: "
+3 SET RESULTS(2)=$EXTRACT(RMPRSSN,1,3)_"-"_$EXTRACT(RMPRSSN,4,5)_"-"_$EXTRACT(RMPRSSN,6,10)
+4 SET RESULTS(3)=$GET(R19(660,RMPRDA,8,"E"))
+5 ; "DOB: "
+6 SET RESULTS(4)=$SELECT(RMPRDOB:$EXTRACT(RMPRDOB,4,5)_"-"_$EXTRACT(RMPRDOB,6,7)_"-"_(1700+$EXTRACT(RMPRDOB,1,3)),1:"Unknown")
+7 QUIT
EXIT ;common exit point
+1 IF '$DATA(RESULTS)
SET RESULTS(0)="NOTHING TO REPORT"
+2 KILL R19,RV,RMPRICC,RMPRERR,Y
+3 QUIT
+4 ;end
