- 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 Dec 13, 2024@02:37:41 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