source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRN6PL.m@ 1006

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

initial load of WorldVistAEHR

File size: 3.6 KB
RevLine 
[613]1RMPRN6PL ;HINES/HNC -NPPD CALCULATIONS - SINGLE LINE; 02/14/98
2 ;;3.0;PROSTHETICS;**32,34,36,51,70,72,133**;Feb 09, 1996;Build 2
3 ;
4 ;DBIA # 801 - for this routine, the agreement covers the field
5 ; #.05 Short Description, file #441.
6 ;
7 ;DBIA #10060 - Fileman read of file #200
8 Q
9HOLD ;hold screen
10 K DIR I IOST["C-" W !! S DIR(0)="E" D ^DIR S:+Y'>0 FL=1
11 Q
12HDR W @IOF S PAGE=PAGE+1
13 W !,LN,!,CODE
14 W ?10,^TMP($J,"RMPRCODE",CODE)
15 W ?35,DATE(3)," - ",DATE(4)
16 W ?70,"Page: ",PAGE
17 W !,LN,!
18 I IOM<119 W "NAME",?10,"SSN",?16,"HCPCS",?22,"QTY",?27,"TYPE",?32,"COST",?42,"DATE",?48,"ITEM",?62,"HCPCS DES",?76,"WHO",!,LN
19 I IOM>119 W "NAME",?10,"SSN",?16,"HCPCS",?22,"QTY",?27,"TYPE",?32,"COST",?42,"DATE",?48,"ITEM",?80,"HCPCS DES",?112,"WHO",?117,"#",!,LN
20 Q
21DESP ;desplay detail records
22 S FL=""
23 ;code is user defined
24 ;F S CODE=$O(^TMP($J,CODE)) Q:CODE="N" G:FL=1 EXIT D
25 D HDR
26 S RDX=0
27 F S RDX=$O(^TMP($J,CODE,RDX)) D:RDX'>0 HOLD Q:RDX'>0 Q:FL=1 D
28 .S DFN=$P(^RMPR(660,RDX,0),U,2) Q:DFN=""
29 .D DEM^VADPT
30 .I $Y+6>IOSL,IOST["C-" K DIR W !! S DIR(0)="E" D ^DIR S:+Y'>0 FL=1 Q:+Y'>0 D HDR
31 .I $Y+6>IOSL,IOST'["C-" D HDR
32 .W !,$E($P(VADM(1),",",1),1,9)
33 .W ?10,$P(VADM(2),"-",3)
34 .S ITEM="",HCPCSD=""
35 .S TYPE=$P(^RMPR(660,RDX,0),U,4)
36 .S QTY=$P(^RMPR(660,RDX,0),U,7)
37 .S HCPCS=$P($G(^RMPR(660,RDX,1)),U,4)
38 .I HCPCS=""&($P(^RMPR(660,RDX,0),U,17)'="") S HCPCS=2676,ITEM="SHIPPING",HCPCSD="SHIPPING"
39 .I $P(^RMPR(660,RDX,0),U,26)'="" S ITEM="PICKUP/DEL"
40 .I HCPCSD="" S HCPCSD=$P($G(^RMPR(661.1,HCPCS,0)),U,2)
41 .S HCPCS=$P($G(^RMPR(661.1,HCPCS,0)),U,1)
42 .S WHO=$$GET1^DIQ(200,$P($G(^RMPR(660,RDX,0)),U,27),1)
43 .I $G(RDX) S OPEN=$P(^RMPR(660,RDX,0),U,12)
44 .I OPEN="" S OPEN="*"
45 .E S OPEN=" "
46 .S COST=^TMP($J,CODE,RDX)
47 .S SOURCE=$P(^RMPR(660,RDX,0),U,14)
48 .S DATE=$P(^RMPR(660,RDX,0),U,1),DATE=$E(DATE,4,5)_"/"_$E(DATE,6,7)
49 .I ITEM="" S ITEM=$P($G(^PRC(441,+$P($G(^RMPR(661,+$P($G(^RMPR(660,RDX,0)),U,6),0)),U,1),0)),U,2)
50 .I IOM<119 W ?16,HCPCS,?22,QTY,?27,TYPE,?29,SOURCE,?32,OPEN,COST,?42,DATE,?48,$E(ITEM,1,11),?61,"|",?62,$E(HCPCSD,1,12),?76,WHO
51 .I IOM>118 W ?16,HCPCS,?22,QTY,?27,TYPE,?29,SOURCE,?32,OPEN,COST,?42,DATE,?48,$E(ITEM,1,29),?79,"|",?80,$E(HCPCSD,1,30),?112,WHO,?117,RDX
52 K ITEM,HCPCSD
53 Q
54DESPR ;repair dispaly
55 ;
56 ;S CODE="R1"
57 ;code is user defined
58 F S CODE=$O(^TMP($J,CODE)) Q:CODE["RMPR" Q:FL=1 D
59 .D HDR
60 .S RDX=0
61 .F S RDX=$O(^TMP($J,CODE,RDX)) D:RDX'>0 HOLD Q:RDX'>0 Q:FL=1 D
62 ..S DFN=$P(^RMPR(660,RDX,0),U,2) Q:DFN=""
63 ..D DEM^VADPT
64 ..Q:FL=1
65 ..I $Y+6>IOSL,IOST["C-" K DIR W !! S DIR(0)="E" D ^DIR S:+Y'>0 FL=1 Q:+Y'>0 D HDR
66 ..I $Y+6>IOSL,IOST'["C-" D HDR
67 ..W !,$E($P(VADM(1),",",1),1,9)
68 ..W ?10,$P(VADM(2),"-",3)
69 ..S TYPE=$P(^RMPR(660,RDX,0),U,4)
70 ..S QTY=$P(^RMPR(660,RDX,0),U,7)
71 ..I $P(^RMPR(660,RDX,0),U,17)'="" S HCPCS="#SHIP",ITEM="SHIPPING"
72 ..S:$G(HCPCS)'["#" HCPCS=$P(^RMPR(661.1,$P(^RMPR(660,RDX,1),U,4),0),U,1)
73 ..S:$G(HCPCS)'["#" HCPCSD=$P(^RMPR(661.1,$P(^RMPR(660,RDX,1),U,4),0),U,2)
74 ..I $G(HCPCS)["#" S HCPCSD="SHIPPING"
75 ..S WHO=$$GET1^DIQ(200,$P($G(^RMPR(660,RDX,0)),U,27),1)
76 ..S OPEN=""
77 ..I $G(RDZ) S OPEN=$P(^RMPR(660,RDZ,0),U,12)
78 ..I OPEN="" S OPEN="*"
79 ..E S OPEN=" "
80 ..S COST=^TMP($J,CODE,RDX)
81 ..S SOURCE=$P(^RMPR(660,RDX,0),U,14)
82 ..S DATE=$P(^RMPR(660,RDX,0),U,1),DATE=$E(DATE,4,5)_"/"_$E(DATE,6,7)
83 ..S:$G(ITEM)'["SHIPPING" ITEM=$P(^PRC(441,$P(^RMPR(661,$P(^RMPR(660,RDX,0),U,6),0),U,1),0),U,2)
84 ..I IOM<119 W ?16,HCPCS,?22,QTY,?27,TYPE,?29,SOURCE,?32,OPEN,COST,?42,DATE,?48,$E(ITEM,1,12),?62,$E(HCPCSD,1,12),?76,WHO
85 ..I IOM>118 W ?16,HCPCS,?22,QTY,?27,TYPE,?29,SOURCE,?32,OPEN,COST,?42,DATE,?48,$E(ITEM,1,29),?79,"|",?80,$E(HCPCSD,1,30),?112,WHO,?117,RDX
86 Q
87EXIT ;
88 Q
89 ;END
Note: See TracBrowser for help on using the repository browser.