source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR9S4.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 5.0 KB
Line 
1RMPR9S4 ;HOIFO/HNC - GUI 2319 ITEM TRANSACTIONS LIST ;9/10/02 08:42
2 ;;3.0;PROSTHETICS;**59,99,90,75**;Feb 09, 1996;Build 25
3 ;IEN = INTERNAL ENTRY NUMBER OF FILE 668
4 Q
5A1(IEN) G A2
6EN(RESULTS,IEN) ;broker
7A2 S (RA,AN,ANS,RK,RZ)=0 K ^TMP($J,"TT"),^TMP($J,"AG"),IT
8 K ^TMP($J,"RMPRB")
9 K ^TMP($J,"RMPRC"),RMPRLPRO
10 ;IT IS RESULTS
11 ;0;2 DFN in 668
12 S RMPRDFN=$P($G(^RMPR(668,IEN,0)),U,2)
13 I RMPRDFN="" S ^TMP($J,"RMPRB",1)="PATIENT NOT KNOWN" Q
14 MERGE ^TMP($J,"TT")=^RMPR(660,"AC",RMPRDFN)
15 S B=0
16 F S B=$O(^TMP($J,"TT",B)) Q:B'>0 D
17 . S BC=0
18 . F S BC=$O(^TMP($J,"TT",B,BC)) Q:BC'>0 D
19 . .;Q:$P($G(^RMPR(660,BC,0)),U,10)'=RMPR("STA")
20 . .S GN=$P($G(^RMPR(660,BC,"AMS")),U,1)
21 . .S ND=$P($G(^RMPR(660,BC,1)),U,4)
22 . .I ND S ND=$P(^RMPR(661.1,ND,0),U,8)
23 . .S:ND="" ND=2
24 . .S:GN="" GN=BC
25 . .S ^TMP($J,"AG",GN,ND,BC)=B
26 S B=""
27 F S B=$O(^TMP($J,"AG",B)) Q:B'>0 D
28 .S BC=""
29 .F S BC=$O(^TMP($J,"AG",B,BC)) Q:BC'>0 D
30 . .Q:BC=2
31 . .MERGE ^TMP($J,"AGG")=^TMP($J,"AG",B)
32 . .S HC="",GTCST=0
33 . .K HCC1
34 . .F S HC=$O(^TMP($J,"AGG",HC)) Q:HC'>0 D
35 . . .S HCC=0
36 . . .;changes for Surgical Implants
37 . . .S BDC=""
38 . . .F BDC=1:1 S HCC=$O(^TMP($J,"AGG",HC,HCC)) Q:HCC'>0 D
39 . . . .S GTCST=GTCST+$P(^RMPR(660,HCC,0),U,16)
40 . . . .I BDC=1&(HC'=2) S HCC1=HCC
41 . . . .I BDC'=1 K ^TMP($J,"TT",^TMP($J,"AGG",HC,HCC),HCC)
42 . . . .I HC=2 K ^TMP($J,"TT",^TMP($J,"AGG",HC,HCC),HCC)
43 . .I $G(HCC1) S $P(^TMP($J,"TT",^TMP($J,"AGG",1,HCC1),HCC1),U,3)=GTCST K HCC1
44 . .K GTCST,^TMP($J,"AGG")
45 K ^TMP($J,"AG"),BDC
46 S B=0,RC=1
47 F S B=$O(^TMP($J,"TT",B)) Q:B'>0 D
48 .S RK=0
49 .F S RK=$O(^TMP($J,"TT",B,RK)) Q:RK'>0 D
50 . .Q:$D(^RMPO(665.72,"AC",RK))
51 . .S ^TMP($J,"RMPRC",RC)=RK
52 . .I $P(^TMP($J,"TT",B,RK),U,3) S $P(^TMP($J,"RMPRC",RC),U,3)=$P(^TMP($J,"TT",B,RK),U,3)
53 . .S RC=RC+1
54 S RK=0,RZ=0
55 K ^TMP($J,"TT"),B
56 ;
57 G:'$D(^TMP($J,"RMPRC")) END
58 ;
59DIS ;format data string - ALL
60 S RC=""
61 S RK=0
62 F S RK=$O(^TMP($J,"RMPRC",RK)) Q:RK="" D
63 .S AN=+^TMP($J,"RMPRC",RK)
64 .S RMPRY=$G(^RMPR(660,AN,0))
65 .I RMPRY'="" D PRT
66 .Q
67 ;
68 ;
69END I RC=0 S ^TMP($J,"RMPRB",1)="NOTHING TO REPORT" G EXIT
70 ;
71 ;
72EXIT ;common exit point
73 ;pass to broker
74 K ^TMP($J,"RMPRC")
75 ;S RESULT=$NA(^TMP($J))
76 M RESULTS=^TMP($J,"RMPRB")
77 I '$D(RESULTS) S RESULTS(0)="NOTHING TO REPORT"
78 K I,J,L,R0,RA
79 Q
80PRT ;
81 S DATE=$P(RMPRY,U,3),TYPE=$P(RMPRY,U,6),QTY=$P(RMPRY,U,7)
82 S VEN=$P(RMPRY,U,9),TRANS=$P(RMPRY,U,4),STA=$P(RMPRY,U,10),SN=$P(RMPRY,U,11)
83 S DEL=$P(RMPRY,U,12)
84 S CST=$S($P(RMPRY,U,16)'="":$P(RMPRY,U,16),$D(^RMPR(660,AN,"LB")):$P(^RMPR(660,AN,"LB"),U,9),1:"")
85 ;lab source of procurement
86 I $D(^RMPR(660,AN,"LB")) S RMPRLPRO=$P(^("LB"),U,3) D
87 .I RMPRLPRO="O" S RMPRLPRO="ORTHOTIC" Q
88 .I RMPRLPRO="R" S RMPRLPRO="RESTORATION" Q
89 .I RMPRLPRO="S" S RMPRLPRO="SHOE" Q
90 .I RMPRLPRO="W" S RMPRLPRO="WHEELCHAIR" Q
91 .I RMPRLPRO="N" S RMPRLPRO="FOOT CENTER" Q
92 .I RMPRLPRO="D" S RMPRLPRO="DDC" Q
93 .I RMPRLPRO="E" S RMPRLPRO="EYE GLASS" Q
94 .I RMPRLPRO="" K RMPRLPRO
95 ;form requested on
96 S FRM=$P(RMPRY,U,13)
97 S RMPRNC=$P($G(^RMPR(660,AN,"AM")),U,2)
98 S DATE=$$DAT2^RMPRUTL1(DATE)
99 S TYPE=$P($G(^RMPR(660,AN,1)),U,4)
100 ;S TYPE=$S(TYPE="":"",$D(^RMPR(661,TYPE,0)):$P(^(0),U,1),1:"")
101 S AMIS=$P(RMPRY,U,15),VEN=$S(VEN="":"",$D(^PRC(440,VEN,0)):$P(^(0),U,1),1:"")
102 I $D(^RMPR(660.1,"AC",AN)),$P(^RMPR(660.1,$O(^RMPR(660.1,"AC",AN,0)),0),U,11)]"" S AMIS=AMIS_"+"
103 S TRANS=$S(TRANS]"":TRANS,1:""),TRANS1="" S:TRANS="X" TRANS1=TRANS,TRANS=""
104 S DEL=$E(DEL,4,5)_"/"_$E(DEL,6,7)_"/"_$E(DEL,2,3) S:DEL="//" DEL=""
105 ;
106 ;set results array
107 ;
108 S HTYPE=""
109 I $D(^RMPR(660,$P(^TMP($J,"RMPRC",RK),U,1),"HST")) S HTYPE=$E(^RMPR(660,$P(^TMP($J,"RMPRC",RK),U,1),"HST"),1,15)
110 S ITEM=AMIS_$S(TYPE'="":$P($G(^RMPR(661.1,TYPE,0)),U,2),$P(RMPRY,U,26)="D":"DELIVERY",$P(RMPRY,U,26)="P":"PICKUP",$P(RMPRY,U,17):"SHIPPING",HTYPE'="":HTYPE,1:"")
111 K HTYPE
112 ;
113 S HCPCS=$P($G(^RMPR(660,$P(^TMP($J,"RMPRC",RK),U,1),1)),U,4)
114 I HCPCS'="" S HCPCS=$P($G(^RMPR(661.1,HCPCS,0)),U,1)
115 ;
116 S ^TMP($J,"RMPRB",RK)=$P(^TMP($J,"RMPRC",RK),U,1)_U_DATE_U_QTY_U_ITEM
117 S ^TMP($J,"RMPRB",RK)=^TMP($J,"RMPRB",RK)_U_HCPCS_U_TRANS_TRANS1
118 ;
119 ;display source of procurement for 2529-3 under vendor header
120 I $D(RMPRLPRO) S ^TMP($J,"RMPRB",RK)=^TMP($J,"RMPRB",RK)_U_RMPRLPRO
121 E S:VEN'="" ^TMP($J,"RMPRB",RK)=^TMP($J,"RMPRB",RK)_U_$E(VEN,1,10)
122 I VEN=""&'$D(RMPRLPRO) S:'$D(^RMPR(660,$P(^TMP($J,"RMPRC",RK),U,1),"HST")) ^TMP($J,"RMPRB",RK)=^TMP($J,"RMPRB",RK)_U_$E(VEN,1,10)
123 I VEN=""&'$D(RMPRLPRO) S:$D(^RMPR(660,$P(^TMP($J,"RMPRC",RK),U,1),"HST")) ^TMP($J,"RMPRB",RK)=^TMP($J,"RMPRB",RK)_U_$E($P(^RMPR(660,$P(^TMP($J,"RMPRC",RK),U,1),"HST"),U,3),1,10)
124 ;
125 I STA'="" S ^TMP($J,"RMPRB",RK)=^TMP($J,"RMPRB",RK)_U_$P($G(^DIC(4,STA,99)),U,1)
126 I STA="" S ^TMP($J,"RMPRB",RK)=^TMP($J,"RMPRB",RK)_U_"UNKNOWN"
127 S ^TMP($J,"RMPRB",RK)=^TMP($J,"RMPRB",RK)_U_SN_U_DEL
128 I $P(^TMP($J,"RMPRC",RK),U,3) S CST=$P(^TMP($J,"RMPRC",RK),U,3)
129 S COST=$J($FN($S(CST'="":CST,$P(RMPRY,U,17):$P(RMPRY,U,17),1:""),"T",2),9)
130 ;
131 S ^TMP($J,"RMPRB",RK)=^TMP($J,"RMPRB",RK)_U_COST_U_RMPRNC
132 ;
133 I $P(^TMP($J,"RMPRC",RK),U,2)="" S $P(^TMP($J,"RMPRC",RK),U,2)=RZ
134 K DATE,QTY,ITEM,HCPSC,RMPRLPRO,VEN,SN,DEL,COST,REM
135 ;
136 Q
137 ;END
Note: See TracBrowser for help on using the repository browser.