RMPRSE21 ;HINES CIOFO/HNB - SEARCH FILE 660 ENTRIES PSAS HCPCS HISTORY;1/23/1998
;;3.0;PROSTHETICS;**36,62,77,92,90,128,168**;Feb 09, 1996;Build 43
;
; Reference to $$SINFO^ICDEX supported by ICR #5747
; Reference to $$ICDDX^ICDEX supported by ICR #5747
; Reference to $$VLT^ICDEX supported by ICR #5747
;
; RVD patch #62 - add ICD9 code and Description in the output
; RVD patch #77 3/17/03 - use RMPR("STA") instead of $$STA^RMPRUTIL
;
; AAC Patch 92 08/03/04 - Code Set Versioning (CSV)
;
EN S (ITEM,RMPRARR,RMPRI,RMPRDA)=""
K KILL
D HOME^%ZIS,DIV4^RMPRSIT G:$D(X) EXIT1
W !!!
S DIC="^RMPR(661.1,",DIC(0)="AEQM"
F ITEM=1:1 S DIC("A")="Select PSAS HCPCS ("_ITEM_"): " D ^DIC G:$D(DTOUT)!(X["^")!(X=""&(ITEM=1)) EXIT1 Q:X="" D
.I $D(RMPRI(+Y)) W !,$C(7)," ??",?40,"..Duplicate PSAS HCPCS" S ITEM=ITEM-1 Q
.S RMPRARR(ITEM)=+Y,RMPRI(+Y)=""
S RMPRCOUN=0 W !! S %DT("A")="Beginning Date: ",%DT="AEPX",%DT("B")="T-30" D ^%DT S RMPRBDT=Y G:Y<0 EXIT1
ENDATE S %DT("A")="Ending Date: ",%DT="AEX",%DT("B")="TODAY"
D ^%DT G:Y<0 EXIT1
I RMPRBDT>Y W !,$C(7),"Invalid Date Range Selection!!" G ENDATE
G:Y<0 EXIT
S RMPREDT=Y,Y=RMPRBDT D DD^%DT S RMPRX=Y,Y=RMPREDT D DD^%DT S RMPRY=Y
S %ZIS="MQ" K IOP D ^%ZIS G:POP EXIT
I '$D(IO("Q")) U IO G PRINT
K IO("Q") S ZTDESC="SEARCH FOR PSAS HCPCS",ZTRTN="PRINT^RMPRSE21",ZTIO=ION,ZTSAVE("RMPRBDT")="",ZTSAVE("RMPREDT")="",ZTSAVE("RMPRI(")="",ZTSAVE("RMPRX")="",ZTSAVE("RMPRY")="",ZTSAVE("RMPR(""STA"")")="",ZTSAVE("RMPRARR(")=""
S ZTSAVE("RMPR(")="",ZTSAVE("RMPRSITE")=""
D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED!" H 1 G EXIT1
PRINT ;ENTRY POINT FOR PRINTING REPORT
S PAGE=1,(RMPRCOUN,RP,QTYT,COSTT)=0
S RQ=0
F S RQ=$O(RMPRARR(RQ)) Q:RQ'>0!($D(KILL)) D D REST
.S RO=$P(RMPRARR(RQ),U,1),RO=RO-1
.F S RO=$O(^RMPR(660,"H",RO)) Q:RO'>0 D
. .Q:RO=""!(RO'=$P(RMPRARR(RQ),U))!($D(KILL))
. .K ENDD
. .F S RP=$O(^RMPR(660,"H",RO,RP)) Q:RP=""!($D(KILL)) D CK
G EXIT
Q
EXIT ;EXIT FROM REPORT HERE
I RMPRCOUN>0,$D(RMPREDT),'$D(KILL) W !!?32,"END OF REPORT"
I $E(IOST)["C"&($Y<22),'$D(ENDD) F W ! Q:$Y>20
I $D(RMPREDT),$E(IOST)["C",'$D(RMPRFLL),'$D(KILL),'$D(DUOUT),'$D(DTOUT),'$D(ENDD) K DIR S DIR(0)="E" D ^DIR
EXIT1 K RMPRARR,%DT,GOTO,QTYT,ITEM,KILL,ENDD,RQ,RP,RO,ITEM,RMPRI,COSTT,DIC,DIR,PAGE,RO,RMPRCOUN,RMPRSE,RMPRBDT,RMPREDT,RMPRX,RMPRY D ^%ZISC
Q
CK Q:'$D(^RMPR(660,RP,0))
;hcpcs
I ('$P(^RMPR(660,RP,1),U,4))!($P(^(0),U,3)<RMPRBDT)!($P(^(0),U,3)>RMPREDT) Q
I $P(^RMPR(660,RP,0),U,10)'=RMPR("STA") Q
;
I $P(RMPRARR(RQ),U,1)=$P(^RMPR(660,RP,1),U,4) D CON
Q
;
CON I $Y>(IOSL-6),PAGE=1,'RMPRCOUN W @IOF
D HEAD S RMPRCOUN=RMPRCOUN+1
S (RMPRDA,Y)=$P(^RMPR(660,RP,0),U,3) D DD^%DT
W !,Y,?15,$E($P(^DPT($P(^RMPR(660,RP,0),U,2),0),U,1),1,13),?30,$E($P(^DPT($P(^RMPR(660,RP,0),U,2),0),U,9),6,9)
W:$P(^RMPR(660,RP,0),U,9)'="" ?36,$E($P(^PRC(440,$P(^RMPR(660,RP,0),U,9),0),U,1),1,35)
W !,"ITEM: " S ITMP=$P(^RMPR(660,RP,0),U,6)
W:ITMP'="" $E($P(^PRC(441,$P(^RMPR(661,ITMP,0),U,1),0),U,2),1,20)
K ITMP
I $P(^RMPR(660,RP,0),U,13)=4 D
.W ?27,"QTY: ",$J($P(^RMPR(660,RP,0),U,7),4),?38,"TOTAL COST: ",$J($FN($P(^("LB"),U,9),"P",2),8) S QTYT=QTYT+$P(^(0),U,7),COSTT=COSTT+$P(^("LB"),U,9)
I $P(^RMPR(660,RP,0),U,13)'=4 W ?27,"QTY: ",$J($P(^RMPR(660,RP,0),U,7),4),?38,"TOTAL COST: ",$J($FN($P(^(0),U,16),"P",2),8) S QTYT=QTYT+$P(^(0),U,7),COSTT=COSTT+$P(^(0),U,16)
W ?60,$S($P(^RMPR(660,RP,0),U,4)="I":"INITIAL ISSUE",$P(^(0),U,4)="R":"REPLACEMENT",$P(^(0),U,4)="S":"SPARE",$P(^(0),U,4)="X":"REPAIR",$P(^(0),U,4)="5":"RENTAL",1:"UNK"),!,"INITIATOR: "
I $P(^RMPR(660,RP,0),U,27),$D(^VA(200,$P(^(0),U,27),0)) W ?15,$P(^(0),U)
;
; Patch 92 - Code Set Versioning (CSV) changes below
; AAC - 08/03/04
; Changes for ICD-10 Class I Remediation Project
;
N RMPRACS,RMPRACSI,RMPRCNT,RMPRDAT,RMPRDATA,RMPRERR,RMPRICD,RMPRSICD
N RMPRPROD,RMPRTOR,RMPRTXT1
S (RMPRACS,RMPRACSI,RMPRDAT,RMPRDATA,RMPRICD,RMPRSICD)=""
S (RMPRPROD,RMPRTOR,RMPRTXT1)=""
S RMPRERR=0
S RMPRDAT=$P($G(^RMPR(660,RP,0)),U,1)
; Determine Active Coding System based on Date of Interest
S RMPRACS=$$SINFO^ICDEX("DIAG",RMPRDAT) ; Supported by ICR 5747
S RMPRACSI=$P(RMPRACS,U,1)
S RMPRACS=$P(RMPRACS,U,2)
S RMPRACS=$S(RMPRACS="ICD-9-CM":"ICD-9 ",RMPRACS="ICD-10-CM":"ICD-10 ",1:"ICD: ")
;
; Load Suspense data
S RMPRDATA=$G(^RMPR(660,RP,10))
I RMPRDATA'="" D
.S RMPRTOR=$P(RMPRDATA,U,5) ; TYPE OF REQUEST #8.5
.S RMPRPROD=$P(RMPRDATA,U,7) ; PROVISIONAL DIAGNOSIS #8.7
.S RMPRSICD=$P(RMPRDATA,U,8) ; SUSPENSE ICD #8.8
;
; If SUSPENSE ICD existed, retrieve data
I RMPRSICD'="" D
.; Use new API to return ICD Data
.S RMPRICD=$$ICDDX^ICDEX(RMPRSICD,RMPRDAT,RMPRACSI,"I") ; Supported by ICR 5747
.S RMPRERR=$P(RMPRICD,U,1)
.; Update error message to display either ICD-9 or ICD-10 based on Date Of Interest
.I RMPRERR<0 W !,RMPRACS_"Message: "_$P(RMPRICD,U,2) Q
.; Retrieve full ICD Description
.S RMPRTXT(2)=$$VLT^ICDEX(80,+RMPRICD,RMPRDAT) ; Supported by ICR 5747
;
; Check for Manual Suspense and adjust line label if needed
S RMPRTXT(1)=$S(RMPRTOR="MANUAL"&(RMPRSICD=""):"MANUAL SUSPENSE: ",1:RMPRACS_"CODE: ")
;
I +$G(RMPRSICD) D
.S RMPRTXT(1)=RMPRTXT(1)_$P(RMPRICD,U,2)_" "
.;
.; Process SUSPENSE ICD
.I $P(RMPRICD,U,10)'>0 D
..S Y=$P(RMPRICD,U,12) ; Inactive Date
..D DD^%DT
..S RMPRTXT(3)=" ** Inactive ** Date: "_Y
.;
.; Parse ICD data into 80 char array
.D PARSE^RMPOPED(.RMPRTXT)
;
; Loop to display ICD and Suspense info
F RMPRCNT=1:1 Q:'$D(RMPRTXT(RMPRCNT)) W !,RMPRTXT(RMPRCNT)
K RMPRTXT
;
; End of Patch 92 & ICD-10 mods
;
I $E(IOST)["C"&($Y>(IOSL-6)) S DIR(0)="E" D ^DIR S:Y<1 KILL=1 Q:Y<1 K DIR W @IOF D HEAD Q
I $Y>(IOSL-6) W @IOF D HEAD
Q
;
HEAD I $Y<2!(PAGE=1) D
.N RMPRSTAW
.S RMPRSTAW=RMPR("STA")
.I RMPRSTAW'="",$D(^DIC(4,RMPRSTAW,99)) S RMPRSTAW=$P(^DIC(4,RMPRSTAW,99),U)
.W !,"PSAS HCPCS HISTORY:",?15
.W $E($P(^RMPR(661.1,$P(^RMPR(660,RP,1),U,4),0),U,1),1,39)
.W ?63,"STA ",RMPRSTAW,?72,"PAGE ",PAGE S PAGE=PAGE+1
.W !!,"REQUEST DATE",?15,"PATIENT NAME",?30,"SSN",?36,"VENDOR"
.S Y=RMPRBDT D DD^%DT W ?55,Y,"-" S Y=RMPREDT D DD^%DT W Y
.W ! F BH=1:1:IOM W "="
Q
;
REST D:'RMPRCOUN NONE Q:$D(KILL)!('RMPRCOUN) W !,"TOTAL DOLLARS SPENT ON THIS HCPCS: ","$"_$J($FN(COSTT,"P",2),9),?45,"TOTAL QUANTITY ISSUED: ",$J(QTYT,4)
I $O(RMPRARR(RQ)),$E(IOST)["C" W ! K DIR S DIR(0)="E" D ^DIR S:Y<1 KILL=1 W:'$D(KILL) @IOF
I $E(IOST)'["C",$O(RMPRARR(RQ)) W @IOF
S (COSTT,QTYT,RMPRCOUN)=""
Q
;
NONE W @IOF,!!,"No '",$P(^RMPR(661.1,RMPRARR(RQ),0),U,1),"' PSAS HCPCS History for this date range.",!
;,$P(^PRC(441,$P(^RMPR(661,$P(RMPRARR(RQ),U),0),U),0),U,2)
I $E(IOST)["C" K DIR S DIR(0)="E" W !!!! D ^DIR W @IOF S:Y<1 KILL=1 S ENDD=1
Q
XREF ;set new x-ref for the field HCPCS in 660
;fix HCPCS VA117, REMOVE BLANK SPACE IN R90
S $P(^RMPR(661.1,2801,0),U,6)="R90"
W !!,"New Cross Reference for HCPCS..."
S DIK="^RMPR(660,",DIK(1)="4.5^H" D ENALL^DIK
W !!,"Done"
Q
;END
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRSE21 7056 printed Apr 09, 2024@21:40:45 Page 2
RMPRSE21 ;HINES CIOFO/HNB - SEARCH FILE 660 ENTRIES PSAS HCPCS HISTORY;1/23/1998
+1 ;;3.0;PROSTHETICS;**36,62,77,92,90,128,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 ; Reference to $$VLT^ICDEX supported by ICR #5747
+6 ;
+7 ; RVD patch #62 - add ICD9 code and Description in the output
+8 ; RVD patch #77 3/17/03 - use RMPR("STA") instead of $$STA^RMPRUTIL
+9 ;
+10 ; AAC Patch 92 08/03/04 - Code Set Versioning (CSV)
+11 ;
EN SET (ITEM,RMPRARR,RMPRI,RMPRDA)=""
+1 KILL KILL
+2 DO HOME^%ZIS
DO DIV4^RMPRSIT
if $DATA(X)
GOTO EXIT1
+3 WRITE !!!
+4 SET DIC="^RMPR(661.1,"
SET DIC(0)="AEQM"
+5 FOR ITEM=1:1
SET DIC("A")="Select PSAS HCPCS ("_ITEM_"): "
DO ^DIC
if $DATA(DTOUT)!(X["^")!(X=""&(ITEM=1))
GOTO EXIT1
if X=""
QUIT
Begin DoDot:1
+6 IF $DATA(RMPRI(+Y))
WRITE !,$CHAR(7)," ??",?40,"..Duplicate PSAS HCPCS"
SET ITEM=ITEM-1
QUIT
+7 SET RMPRARR(ITEM)=+Y
SET RMPRI(+Y)=""
End DoDot:1
+8 SET RMPRCOUN=0
WRITE !!
SET %DT("A")="Beginning Date: "
SET %DT="AEPX"
SET %DT("B")="T-30"
DO ^%DT
SET RMPRBDT=Y
if Y<0
GOTO EXIT1
ENDATE SET %DT("A")="Ending Date: "
SET %DT="AEX"
SET %DT("B")="TODAY"
+1 DO ^%DT
if Y<0
GOTO EXIT1
+2 IF RMPRBDT>Y
WRITE !,$CHAR(7),"Invalid Date Range Selection!!"
GOTO ENDATE
+3 if Y<0
GOTO EXIT
+4 SET RMPREDT=Y
SET Y=RMPRBDT
DO DD^%DT
SET RMPRX=Y
SET Y=RMPREDT
DO DD^%DT
SET RMPRY=Y
+5 SET %ZIS="MQ"
KILL IOP
DO ^%ZIS
if POP
GOTO EXIT
+6 IF '$DATA(IO("Q"))
USE IO
GOTO PRINT
+7 KILL IO("Q")
SET ZTDESC="SEARCH FOR PSAS HCPCS"
SET ZTRTN="PRINT^RMPRSE21"
SET ZTIO=ION
SET ZTSAVE("RMPRBDT")=""
SET ZTSAVE("RMPREDT")=""
SET ZTSAVE("RMPRI(")=""
SET ZTSAVE("RMPRX")=""
SET ZTSAVE("RMPRY")=""
SET ZTSAVE("RMPR(""STA"")")=""
SET ZTSAVE("RMPRARR(")=""
+8 SET ZTSAVE("RMPR(")=""
SET ZTSAVE("RMPRSITE")=""
+9 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"REQUEST QUEUED!"
HANG 1
GOTO EXIT1
PRINT ;ENTRY POINT FOR PRINTING REPORT
+1 SET PAGE=1
SET (RMPRCOUN,RP,QTYT,COSTT)=0
+2 SET RQ=0
+3 FOR
SET RQ=$ORDER(RMPRARR(RQ))
if RQ'>0!($DATA(KILL))
QUIT
Begin DoDot:1
+4 SET RO=$PIECE(RMPRARR(RQ),U,1)
SET RO=RO-1
+5 FOR
SET RO=$ORDER(^RMPR(660,"H",RO))
if RO'>0
QUIT
Begin DoDot:2
+6 if RO=""!(RO'=$PIECE(RMPRARR(RQ),U))!($DATA(KILL))
QUIT
+7 KILL ENDD
+8 FOR
SET RP=$ORDER(^RMPR(660,"H",RO,RP))
if RP=""!($DATA(KILL))
QUIT
DO CK
End DoDot:2
End DoDot:1
DO REST
+9 GOTO EXIT
+10 QUIT
EXIT ;EXIT FROM REPORT HERE
+1 IF RMPRCOUN>0
IF $DATA(RMPREDT)
IF '$DATA(KILL)
WRITE !!?32,"END OF REPORT"
+2 IF $EXTRACT(IOST)["C"&($Y<22)
IF '$DATA(ENDD)
FOR
WRITE !
if $Y>20
QUIT
+3 IF $DATA(RMPREDT)
IF $EXTRACT(IOST)["C"
IF '$DATA(RMPRFLL)
IF '$DATA(KILL)
IF '$DATA(DUOUT)
IF '$DATA(DTOUT)
IF '$DATA(ENDD)
KILL DIR
SET DIR(0)="E"
DO ^DIR
EXIT1 KILL RMPRARR,%DT,GOTO,QTYT,ITEM,KILL,ENDD,RQ,RP,RO,ITEM,RMPRI,COSTT,DIC,DIR,PAGE,RO,RMPRCOUN,RMPRSE,RMPRBDT,RMPREDT,RMPRX,RMPRY
DO ^%ZISC
+1 QUIT
CK if '$DATA(^RMPR(660,RP,0))
QUIT
+1 ;hcpcs
+2 IF ('$PIECE(^RMPR(660,RP,1),U,4))!($PIECE(^(0),U,3)<RMPRBDT)!($PIECE(^(0),U,3)>RMPREDT)
QUIT
+3 IF $PIECE(^RMPR(660,RP,0),U,10)'=RMPR("STA")
QUIT
+4 ;
+5 IF $PIECE(RMPRARR(RQ),U,1)=$PIECE(^RMPR(660,RP,1),U,4)
DO CON
+6 QUIT
+7 ;
CON IF $Y>(IOSL-6)
IF PAGE=1
IF 'RMPRCOUN
WRITE @IOF
+1 DO HEAD
SET RMPRCOUN=RMPRCOUN+1
+2 SET (RMPRDA,Y)=$PIECE(^RMPR(660,RP,0),U,3)
DO DD^%DT
+3 WRITE !,Y,?15,$EXTRACT($PIECE(^DPT($PIECE(^RMPR(660,RP,0),U,2),0),U,1),1,13),?30,$EXTRACT($PIECE(^DPT($PIECE(^RMPR(660,RP,0),U,2),0),U,9),6,9)
+4 if $PIECE(^RMPR(660,RP,0),U,9)'=""
WRITE ?36,$EXTRACT($PIECE(^PRC(440,$PIECE(^RMPR(660,RP,0),U,9),0),U,1),1,35)
+5 WRITE !,"ITEM: "
SET ITMP=$PIECE(^RMPR(660,RP,0),U,6)
+6 if ITMP'=""
WRITE $EXTRACT($PIECE(^PRC(441,$PIECE(^RMPR(661,ITMP,0),U,1),0),U,2),1,20)
+7 KILL ITMP
+8 IF $PIECE(^RMPR(660,RP,0),U,13)=4
Begin DoDot:1
+9 WRITE ?27,"QTY: ",$JUSTIFY($PIECE(^RMPR(660,RP,0),U,7),4),?38,"TOTAL COST: ",$JUSTIFY($FNUMBER($PIECE(^("LB"),U,9),"P",2),8)
SET QTYT=QTYT+$PIECE(^(0),U,7)
SET COSTT=COSTT+$PIECE(^("LB"),U,9)
End DoDot:1
+10 IF $PIECE(^RMPR(660,RP,0),U,13)'=4
WRITE ?27,"QTY: ",$JUSTIFY($PIECE(^RMPR(660,RP,0),U,7),4),?38,"TOTAL COST: ",$JUSTIFY($FNUMBER($PIECE(^(0),U,16),"P",2),8)
SET QTYT=QTYT+$PIECE(^(0),U,7)
SET COSTT=COSTT+$PIECE(^(0),U,16)
+11 WRITE ?60,$SELECT($PIECE(^RMPR(660,RP,0),U,4)="I":"INITIAL ISSUE",$PIECE(^(0),U,4)="R":"REPLACEMENT",$PIECE(^(0),U,4)="S":"SPARE",$PIECE(^(0),U,4)="X":"REPAIR",$PIECE(^(0),U,4)="5":"RENTAL",1:"UNK"),!,"INITIATOR: "
+12 IF $PIECE(^RMPR(660,RP,0),U,27)
IF $DATA(^VA(200,$PIECE(^(0),U,27),0))
WRITE ?15,$PIECE(^(0),U)
+13 ;
+14 ; Patch 92 - Code Set Versioning (CSV) changes below
+15 ; AAC - 08/03/04
+16 ; Changes for ICD-10 Class I Remediation Project
+17 ;
+18 NEW RMPRACS,RMPRACSI,RMPRCNT,RMPRDAT,RMPRDATA,RMPRERR,RMPRICD,RMPRSICD
+19 NEW RMPRPROD,RMPRTOR,RMPRTXT1
+20 SET (RMPRACS,RMPRACSI,RMPRDAT,RMPRDATA,RMPRICD,RMPRSICD)=""
+21 SET (RMPRPROD,RMPRTOR,RMPRTXT1)=""
+22 SET RMPRERR=0
+23 SET RMPRDAT=$PIECE($GET(^RMPR(660,RP,0)),U,1)
+24 ; Determine Active Coding System based on Date of Interest
+25 ; Supported by ICR 5747
SET RMPRACS=$$SINFO^ICDEX("DIAG",RMPRDAT)
+26 SET RMPRACSI=$PIECE(RMPRACS,U,1)
+27 SET RMPRACS=$PIECE(RMPRACS,U,2)
+28 SET RMPRACS=$SELECT(RMPRACS="ICD-9-CM":"ICD-9 ",RMPRACS="ICD-10-CM":"ICD-10 ",1:"ICD: ")
+29 ;
+30 ; Load Suspense data
+31 SET RMPRDATA=$GET(^RMPR(660,RP,10))
+32 IF RMPRDATA'=""
Begin DoDot:1
+33 ; TYPE OF REQUEST #8.5
SET RMPRTOR=$PIECE(RMPRDATA,U,5)
+34 ; PROVISIONAL DIAGNOSIS #8.7
SET RMPRPROD=$PIECE(RMPRDATA,U,7)
+35 ; SUSPENSE ICD #8.8
SET RMPRSICD=$PIECE(RMPRDATA,U,8)
End DoDot:1
+36 ;
+37 ; If SUSPENSE ICD existed, retrieve data
+38 IF RMPRSICD'=""
Begin DoDot:1
+39 ; Use new API to return ICD Data
+40 ; Supported by ICR 5747
SET RMPRICD=$$ICDDX^ICDEX(RMPRSICD,RMPRDAT,RMPRACSI,"I")
+41 SET RMPRERR=$PIECE(RMPRICD,U,1)
+42 ; Update error message to display either ICD-9 or ICD-10 based on Date Of Interest
+43 IF RMPRERR<0
WRITE !,RMPRACS_"Message: "_$PIECE(RMPRICD,U,2)
QUIT
+44 ; Retrieve full ICD Description
+45 ; Supported by ICR 5747
SET RMPRTXT(2)=$$VLT^ICDEX(80,+RMPRICD,RMPRDAT)
End DoDot:1
+46 ;
+47 ; Check for Manual Suspense and adjust line label if needed
+48 SET RMPRTXT(1)=$SELECT(RMPRTOR="MANUAL"&(RMPRSICD=""):"MANUAL SUSPENSE: ",1:RMPRACS_"CODE: ")
+49 ;
+50 IF +$GET(RMPRSICD)
Begin DoDot:1
+51 SET RMPRTXT(1)=RMPRTXT(1)_$PIECE(RMPRICD,U,2)_" "
+52 ;
+53 ; Process SUSPENSE ICD
+54 IF $PIECE(RMPRICD,U,10)'>0
Begin DoDot:2
+55 ; Inactive Date
SET Y=$PIECE(RMPRICD,U,12)
+56 DO DD^%DT
+57 SET RMPRTXT(3)=" ** Inactive ** Date: "_Y
End DoDot:2
+58 ;
+59 ; Parse ICD data into 80 char array
+60 DO PARSE^RMPOPED(.RMPRTXT)
End DoDot:1
+61 ;
+62 ; Loop to display ICD and Suspense info
+63 FOR RMPRCNT=1:1
if '$DATA(RMPRTXT(RMPRCNT))
QUIT
WRITE !,RMPRTXT(RMPRCNT)
+64 KILL RMPRTXT
+65 ;
+66 ; End of Patch 92 & ICD-10 mods
+67 ;
+68 IF $EXTRACT(IOST)["C"&($Y>(IOSL-6))
SET DIR(0)="E"
DO ^DIR
if Y<1
SET KILL=1
if Y<1
QUIT
KILL DIR
WRITE @IOF
DO HEAD
QUIT
+69 IF $Y>(IOSL-6)
WRITE @IOF
DO HEAD
+70 QUIT
+71 ;
HEAD IF $Y<2!(PAGE=1)
Begin DoDot:1
+1 NEW RMPRSTAW
+2 SET RMPRSTAW=RMPR("STA")
+3 IF RMPRSTAW'=""
IF $DATA(^DIC(4,RMPRSTAW,99))
SET RMPRSTAW=$PIECE(^DIC(4,RMPRSTAW,99),U)
+4 WRITE !,"PSAS HCPCS HISTORY:",?15
+5 WRITE $EXTRACT($PIECE(^RMPR(661.1,$PIECE(^RMPR(660,RP,1),U,4),0),U,1),1,39)
+6 WRITE ?63,"STA ",RMPRSTAW,?72,"PAGE ",PAGE
SET PAGE=PAGE+1
+7 WRITE !!,"REQUEST DATE",?15,"PATIENT NAME",?30,"SSN",?36,"VENDOR"
+8 SET Y=RMPRBDT
DO DD^%DT
WRITE ?55,Y,"-"
SET Y=RMPREDT
DO DD^%DT
WRITE Y
+9 WRITE !
FOR BH=1:1:IOM
WRITE "="
End DoDot:1
+10 QUIT
+11 ;
REST if 'RMPRCOUN
DO NONE
if $DATA(KILL)!('RMPRCOUN)
QUIT
WRITE !,"TOTAL DOLLARS SPENT ON THIS HCPCS: ","$"_$JUSTIFY($FNUMBER(COSTT,"P",2),9),?45,"TOTAL QUANTITY ISSUED: ",$JUSTIFY(QTYT,4)
+1 IF $ORDER(RMPRARR(RQ))
IF $EXTRACT(IOST)["C"
WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
if Y<1
SET KILL=1
if '$DATA(KILL)
WRITE @IOF
+2 IF $EXTRACT(IOST)'["C"
IF $ORDER(RMPRARR(RQ))
WRITE @IOF
+3 SET (COSTT,QTYT,RMPRCOUN)=""
+4 QUIT
+5 ;
NONE WRITE @IOF,!!,"No '",$PIECE(^RMPR(661.1,RMPRARR(RQ),0),U,1),"' PSAS HCPCS History for this date range.",!
+1 ;,$P(^PRC(441,$P(^RMPR(661,$P(RMPRARR(RQ),U),0),U),0),U,2)
+2 IF $EXTRACT(IOST)["C"
KILL DIR
SET DIR(0)="E"
WRITE !!!!
DO ^DIR
WRITE @IOF
if Y<1
SET KILL=1
SET ENDD=1
+3 QUIT
XREF ;set new x-ref for the field HCPCS in 660
+1 ;fix HCPCS VA117, REMOVE BLANK SPACE IN R90
+2 SET $PIECE(^RMPR(661.1,2801,0),U,6)="R90"
+3 WRITE !!,"New Cross Reference for HCPCS..."
+4 SET DIK="^RMPR(660,"
SET DIK(1)="4.5^H"
DO ENALL^DIK
+5 WRITE !!,"Done"
+6 QUIT
+7 ;END
