- RMPRSE2 ;PHX/RFM/HNB -SEARCH FILE 660 ENTRIES FOR HCPCS HISTORY ;1/23/1998
- ;;3.0;PROSTHETICS;**28,30,32,36,46,77,90**;Feb 09, 1996
- ;RVD 3/17/03 patch #77 - allow queing to p-message. IO to ION.
- ;this routine is modified for future patch
- EN S (ITEM,RMPRARR,RMPRI)=""
- K KILL
- D HOME^%ZIS,DIV4^RMPRSIT G:$D(X) EXIT1
- W !!!
- S DIC="^ICPT(",DIC(0)="AEQM"
- F ITEM=1:1 S DIC("A")="Select HCPCS ("_ITEM_"): " D ^DIC G:$D(DTOUT)!(X["^")!(X=""&(ITEM=1)) EXIT1 Q:X="" D
- .I $D(RMPRI(+Y)) W !,$C(7)," ??",?40,"..Duplicate 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 RECALLED ITEM",ZTRTN="PRINT^RMPRSE2",ZTIO=ION,ZTSAVE("RMPRBDT")="",ZTSAVE("RMPREDT")="",ZTSAVE("RMPRI(")="",ZTSAVE("RMPRX")="",ZTSAVE("RMPRY")="",ZTSAVE("RMPR(""STA"")")="",ZTSAVE("RMPRARR(")=""
- S 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,"G",RO)) Q:RO'>0 D
- . .Q:RO=""!(RO'=$P(RMPRARR(RQ),U))!($D(KILL))
- . .K ENDD
- . .F S RP=$O(^RMPR(660,"G",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(^(0),U,22))!($P(^(0),U,3)<RMPRBDT)!($P(^(0),U,3)>RMPREDT) Q
- I $P(^RMPR(660,RP,0),U,10)'=RMPR("STA") Q
- ;I '$D(^PRC(441,$P(^RMPR(661,$P(^(0),U,6),0),U))) Q
- I $P(RMPRARR(RQ),U,1)=$P(^RMPR(660,RP,0),U,22) D CON
- Q
- ;
- CON I $Y>(IOSL-6),PAGE=1,'RMPRCOUN W @IOF
- D HEAD S RMPRCOUN=RMPRCOUN+1
- S 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),!
- 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
- .W !,"HCPCS HISTORY:",?15
- .W $E($P(^ICPT($P(^RMPR(660,RP,0),U,22),0),U,1),1,39)
- .W ?63,"STA ",$$STA^RMPRUTIL,?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(^ICPT(RMPRARR(RQ),0),U,1),"' 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
- W !!,"New Cross Reference for HCPCS..."
- S DIK="^RMPR(660,",DIK(1)="4.1^G" D ENALL^DIK
- Q
- ;END
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRSE2 4567 printed Mar 13, 2025@21:42:34 Page 2
- RMPRSE2 ;PHX/RFM/HNB -SEARCH FILE 660 ENTRIES FOR HCPCS HISTORY ;1/23/1998
- +1 ;;3.0;PROSTHETICS;**28,30,32,36,46,77,90**;Feb 09, 1996
- +2 ;RVD 3/17/03 patch #77 - allow queing to p-message. IO to ION.
- +3 ;this routine is modified for future patch
- EN SET (ITEM,RMPRARR,RMPRI)=""
- +1 KILL KILL
- +2 DO HOME^%ZIS
- DO DIV4^RMPRSIT
- if $DATA(X)
- GOTO EXIT1
- +3 WRITE !!!
- +4 SET DIC="^ICPT("
- SET DIC(0)="AEQM"
- +5 FOR ITEM=1:1
- SET DIC("A")="Select 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 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 RECALLED ITEM"
- SET ZTRTN="PRINT^RMPRSE2"
- 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("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,"G",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,"G",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(^(0),U,22))!($PIECE(^(0),U,3)<RMPRBDT)!($PIECE(^(0),U,3)>RMPREDT)
- QUIT
- +3 IF $PIECE(^RMPR(660,RP,0),U,10)'=RMPR("STA")
- QUIT
- +4 ;I '$D(^PRC(441,$P(^RMPR(661,$P(^(0),U,6),0),U))) Q
- +5 IF $PIECE(RMPRARR(RQ),U,1)=$PIECE(^RMPR(660,RP,0),U,22)
- 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 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 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
- +14 IF $Y>(IOSL-6)
- WRITE @IOF
- DO HEAD
- +15 QUIT
- +16 ;
- HEAD IF $Y<2!(PAGE=1)
- Begin DoDot:1
- +1 WRITE !,"HCPCS HISTORY:",?15
- +2 WRITE $EXTRACT($PIECE(^ICPT($PIECE(^RMPR(660,RP,0),U,22),0),U,1),1,39)
- +3 WRITE ?63,"STA ",$$STA^RMPRUTIL,?72,"PAGE ",PAGE
- SET PAGE=PAGE+1
- +4 WRITE !!,"REQUEST DATE",?15,"PATIENT NAME",?30,"SSN",?36,"VENDOR"
- +5 SET Y=RMPRBDT
- DO DD^%DT
- WRITE ?55,Y,"-"
- SET Y=RMPREDT
- DO DD^%DT
- WRITE Y
- +6 WRITE !
- FOR BH=1:1:IOM
- WRITE "="
- End DoDot:1
- +7 QUIT
- +8 ;
- 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(^ICPT(RMPRARR(RQ),0),U,1),"' 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 WRITE !!,"New Cross Reference for HCPCS..."
- +2 SET DIK="^RMPR(660,"
- SET DIK(1)="4.1^G"
- DO ENALL^DIK
- +3 QUIT
- +4 ;END
