source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRSE21.m@ 868

Last change on this file since 868 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 5.3 KB
Line 
1RMPRSE21 ;HINES CIOFO/HNB-SEARCH FILE 660 ENTRIES PSAS HCPCS HISTORY;1/23/1998
2 ;;3.0;PROSTHETICS;**36,62,77,92,90,128**;Feb 09, 1996
3 ; RVD patch #62 - add ICD9 code and Description in the output
4 ; RVD patch #77 3/17/03 - use RMPR("STA") instead of $$STA^RMPRUTIL
5 ;
6 ; AAC Patch 92 08/03/04 - Code Set Versioning (CSV)
7 ; - Used API=ICDDX^ICDCODE to replace direct calls to global ICD9(80).
8 ;
9EN S (ITEM,RMPRARR,RMPRI,RMPRDA)=""
10 K KILL
11 D HOME^%ZIS,DIV4^RMPRSIT G:$D(X) EXIT1
12 W !!!
13 S DIC="^RMPR(661.1,",DIC(0)="AEQM"
14 F ITEM=1:1 S DIC("A")="Select PSAS HCPCS ("_ITEM_"): " D ^DIC G:$D(DTOUT)!(X["^")!(X=""&(ITEM=1)) EXIT1 Q:X="" D
15 .I $D(RMPRI(+Y)) W !,$C(7)," ??",?40,"..Duplicate PSAS HCPCS" S ITEM=ITEM-1 Q
16 .S RMPRARR(ITEM)=+Y,RMPRI(+Y)=""
17 S RMPRCOUN=0 W !! S %DT("A")="Beginning Date: ",%DT="AEPX",%DT("B")="T-30" D ^%DT S RMPRBDT=Y G:Y<0 EXIT1
18ENDATE S %DT("A")="Ending Date: ",%DT="AEX",%DT("B")="TODAY"
19 D ^%DT G:Y<0 EXIT1
20 I RMPRBDT>Y W !,$C(7),"Invalid Date Range Selection!!" G ENDATE
21 G:Y<0 EXIT
22 S RMPREDT=Y,Y=RMPRBDT D DD^%DT S RMPRX=Y,Y=RMPREDT D DD^%DT S RMPRY=Y
23 S %ZIS="MQ" K IOP D ^%ZIS G:POP EXIT
24 I '$D(IO("Q")) U IO G PRINT
25 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(")=""
26 S ZTSAVE("RMPR(")="",ZTSAVE("RMPRSITE")=""
27 D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED!" H 1 G EXIT1
28PRINT ;ENTRY POINT FOR PRINTING REPORT
29 S PAGE=1,(RMPRCOUN,RP,QTYT,COSTT)=0
30 S RQ=0
31 F S RQ=$O(RMPRARR(RQ)) Q:RQ'>0!($D(KILL)) D D REST
32 .S RO=$P(RMPRARR(RQ),U,1),RO=RO-1
33 .F S RO=$O(^RMPR(660,"H",RO)) Q:RO'>0 D
34 . .Q:RO=""!(RO'=$P(RMPRARR(RQ),U))!($D(KILL))
35 . .K ENDD
36 . .F S RP=$O(^RMPR(660,"H",RO,RP)) Q:RP=""!($D(KILL)) D CK
37 G EXIT
38 Q
39EXIT ;EXIT FROM REPORT HERE
40 I RMPRCOUN>0,$D(RMPREDT),'$D(KILL) W !!?32,"END OF REPORT"
41 I $E(IOST)["C"&($Y<22),'$D(ENDD) F W ! Q:$Y>20
42 I $D(RMPREDT),$E(IOST)["C",'$D(RMPRFLL),'$D(KILL),'$D(DUOUT),'$D(DTOUT),'$D(ENDD) K DIR S DIR(0)="E" D ^DIR
43EXIT1 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
44 Q
45CK Q:'$D(^RMPR(660,RP,0))
46 ;hcpcs
47 I ('$P(^RMPR(660,RP,1),U,4))!($P(^(0),U,3)<RMPRBDT)!($P(^(0),U,3)>RMPREDT) Q
48 I $P(^RMPR(660,RP,0),U,10)'=RMPR("STA") Q
49 ;
50 I $P(RMPRARR(RQ),U,1)=$P(^RMPR(660,RP,1),U,4) D CON
51 Q
52 ;
53CON I $Y>(IOSL-6),PAGE=1,'RMPRCOUN W @IOF
54 D HEAD S RMPRCOUN=RMPRCOUN+1
55 S (RMPRDA,Y)=$P(^RMPR(660,RP,0),U,3) D DD^%DT
56 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)
57 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)
58 W !,"ITEM: " S ITMP=$P(^RMPR(660,RP,0),U,6)
59 W:ITMP'="" $E($P(^PRC(441,$P(^RMPR(661,ITMP,0),U,1),0),U,2),1,20)
60 K ITMP
61 I $P(^RMPR(660,RP,0),U,13)=4 D
62 .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)
63 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)
64 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: "
65 I $P(^RMPR(660,RP,0),U,27),$D(^VA(200,$P(^(0),U,27),0)) W ?15,$P(^(0),U)
66 ;
67 ; Patch 92 - Code Set Versioning (CSV) changes below
68 ; AAC - 08/03/04
69 ;
70 S (RMPRICD,RMPRIC9,RMPRCOD,RMPRDAT)="" S RMPRERR=0
71 S RMPRDAT=$P($G(^RMPR(660,RP,0)),U,1)
72 I $D(^RMPR(660,RP,10)) S RMPRIC9=$P(^RMPR(660,RP,10),U,8)
73 I RMPRIC9'="" D
74 .S RMPRICD=$$ICDDX^ICDCODE(RMPRIC9,RMPRDAT)
75 .S RMPRERR=$P(RMPRICD,U,1)
76 .I RMPRERR<0 W !,"ICD-9 Message: ",$P(RMPRICD,U,2)
77 W !,"ICD-9 Code: "
78 I $G(RMPRICD)'="" W $P(RMPRICD,U,2),?19,$E($P(RMPRICD,U,4),1,55) I $P(RMPRICD,U,10)'>0 W " ","** Inactive ** Date: " S Y=$P(RMPRICD,U,12) D DD^%DT W Y
79 W !
80 ;
81 ; END PATCH 92
82 ;
83 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
84 I $Y>(IOSL-6) W @IOF D HEAD
85 Q
86 ;
87HEAD I $Y<2!(PAGE=1) D
88 .N RMPRSTAW
89 .S RMPRSTAW=RMPR("STA")
90 .I RMPRSTAW'="",$D(^DIC(4,RMPRSTAW,99)) S RMPRSTAW=$P(^DIC(4,RMPRSTAW,99),U)
91 .W !,"PSAS HCPCS HISTORY:",?15
92 .W $E($P(^RMPR(661.1,$P(^RMPR(660,RP,1),U,4),0),U,1),1,39)
93 .W ?63,"STA ",RMPRSTAW,?72,"PAGE ",PAGE S PAGE=PAGE+1
94 .W !!,"REQUEST DATE",?15,"PATIENT NAME",?30,"SSN",?36,"VENDOR"
95 .S Y=RMPRBDT D DD^%DT W ?55,Y,"-" S Y=RMPREDT D DD^%DT W Y
96 .W ! F BH=1:1:IOM W "="
97 Q
98 ;
99REST 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)
100 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
101 I $E(IOST)'["C",$O(RMPRARR(RQ)) W @IOF
102 S (COSTT,QTYT,RMPRCOUN)=""
103 Q
104 ;
105NONE W @IOF,!!,"No '",$P(^RMPR(661.1,RMPRARR(RQ),0),U,1),"' PSAS HCPCS History for this date range.",!
106 ;,$P(^PRC(441,$P(^RMPR(661,$P(RMPRARR(RQ),U),0),U),0),U,2)
107 I $E(IOST)["C" K DIR S DIR(0)="E" W !!!! D ^DIR W @IOF S:Y<1 KILL=1 S ENDD=1
108 Q
109XREF ;set new x-ref for the field HCPCS in 660
110 ;fix HCPCS VA117, REMOVE BLANK SPACE IN R90
111 S $P(^RMPR(661.1,2801,0),U,6)="R90"
112 W !!,"New Cross Reference for HCPCS..."
113 S DIK="^RMPR(660,",DIK(1)="4.5^H" D ENALL^DIK
114 W !!,"Done"
115 Q
116 ;END
Note: See TracBrowser for help on using the repository browser.