source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPOPAT2.m@ 1607

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

initial load of FOIAVistA 6/30/08 version
File size: 5.2 KB
Line 
1RMPOPAT2 ;HINES CIO/RVD-DISPLAY PATIENT ITEM ACTIVITY ;9/16/02 11:16
2 ;;3.0;PROSTHETICS;**70,99**;Feb 09, 1996
3 ;RVD 7/5/02 patch #70 - Go to RMPOPAT if Read Only 2319, and
4 ;
5 ;DBIA # 800 - for this routine, the agreement covers the field #.01 NAME
6 ; file #440.
7 ;DBIA # 801 - for this routine, the agreement covers the field
8 ; #.05 Short Description, file #441.
9 ;DBIA # 10090 - Fileman read on file #4, field #99
10 D HDR
11 K ^UTILITY("DIQ1",$J) N DIC,DIQ
12 S (RA,AN,ANS,RK,RZ)=0 K ^TMP($J,"TT"),^TMP($J,"AG"),IT
13 MERGE ^TMP($J,"TT")=^RMPR(660,"AC",RMPRDFN)
14 S B=0
15 F S B=$O(^TMP($J,"TT",B)) Q:B'>0 D
16 . S BC=0
17 . F S BC=$O(^TMP($J,"TT",B,BC)) Q:BC'>0 D
18 . .Q:$P($G(^RMPR(660,BC,0)),U,10)'=RMPR("STA")
19 . .S GN=$P($G(^RMPR(660,BC,"AMS")),U,1)
20 . .S ND=$P($G(^RMPR(660,BC,1)),U,4)
21 . .I ND S ND=$P(^RMPR(661.1,ND,0),U,8)
22 . .S:ND="" ND=2
23 . .S:GN="" GN=BC
24 . .S ^TMP($J,"AG",GN,ND,BC)=B
25 S B=""
26 F S B=$O(^TMP($J,"AG",B)) Q:B'>0 D
27 .S BC=""
28 .F S BC=$O(^TMP($J,"AG",B,BC)) Q:BC'>0 D
29 . .Q:BC=2
30 . .MERGE ^TMP($J,"AGG")=^TMP($J,"AG",B)
31 . .S HC="",GTCST=0
32 . .K HCC1
33 . .F S HC=$O(^TMP($J,"AGG",HC)) Q:HC'>0 D
34 . . .S HCC=0
35 . . .;changes for Surgical Implants
36 . . .S BDC=""
37 . . .F BDC=1:1 S HCC=$O(^TMP($J,"AGG",HC,HCC)) Q:HCC'>0 D
38 . . . .S GTCST=GTCST+$P(^RMPR(660,HCC,0),U,16)
39 . . . .I BDC=1&(HC'=2) S HCC1=HCC
40 . . . .I BDC'=1 K ^TMP($J,"TT",^TMP($J,"AGG",HC,HCC),HCC)
41 . . . .I HC=2 K ^TMP($J,"TT",^TMP($J,"AGG",HC,HCC),HCC)
42 . .I $G(HCC1) S $P(^TMP($J,"TT",^TMP($J,"AGG",1,HCC1),HCC1),U,3)=GTCST K HCC1
43 . .K GTCST,^TMP($J,"AGG")
44 K ^TMP($J,"AG"),BDC
45 S B=0,RC=1
46 F S B=$O(^TMP($J,"TT",B)) Q:B'>0 D
47 .S RK=0
48 .F S RK=$O(^TMP($J,"TT",B,RK)) Q:RK'>0 D
49 . .Q:$D(^RMPO(665.72,"AC",RK))
50 . .S IT(RC)=RK
51 . .I $P(^TMP($J,"TT",B,RK),U,3) S $P(IT(RC),U,3)=$P(^TMP($J,"TT",B,RK),U,3)
52 . .S RC=RC+1
53 S RK=0,RZ=0
54 K ^TMP($J,"TT"),B
55 ;
56 G:'$D(IT) END
57DIS ;DISPLAY APPLIANCES OR REPAIRS
58 I $G(RK)="" S RK="",RC=""
59 I (RK+1'>RC)&($G(IT(RK+1))) S RK=RK+1 S AN=+IT(RK),Y=^RMPR(660,AN,0) D PRT,OVER:((IOSL-4)<$Y) G:'$D(ANS)!(ANS=U)!($D(DUOUT))!($D(DTOUT)) EXIT G DIS
60END I RC=0 W !,"No Appliances or Repairs exist for this veteran!",!! H 3 G EXIT
61 ;
62 I RC>0 W !!,"End of Appliance/Repair records for this veteran!" D OVER I $G(RK)+1'>$G(RC)&($G(IT($G(RK)+1))) D DIS
63 ;
64EXIT K I,J,L,R0,IT,RA,RMPRSTN,RMYSAV,DIQ,^UTILITY("DIQ1",$J)
65 Q:'$D(RMPRDFN)
66 W !
67 I $D(DUOUT)!($D(DTOUT)) G ASK1^RMPOPAT
68 S FL=4 G ASK2^RMPOPAT
69 Q
70PRT MERGE RMYSAV=Y
71 S DATE=$P(Y,U,3),TYPE=$P(Y,U,6),QTY=$P(Y,U,7)
72 S VEN=$P(Y,U,9),TRANS=$P(Y,U,4),STA=$P(Y,U,10),SN=$P(Y,U,11)
73 S DEL=$P(Y,U,12)
74 S CST=$S($P(Y,U,16)'="":$P(Y,U,16),$D(^RMPR(660,AN,"LB")):$P(^RMPR(660,AN,"LB"),U,9),1:"")
75 ;lab source of procurement
76 I $D(^RMPR(660,AN,"LB")) S RMPRLPRO=$P(^("LB"),U,3) D
77 .I RMPRLPRO="O" S RMPRLPRO="ORTHOTIC" Q
78 .I RMPRLPRO="R" S RMPRLPRO="RESTORATION" Q
79 .I RMPRLPRO="S" S RMPRLPRO="SHOE" Q
80 .I RMPRLPRO="W" S RMPRLPRO="WHEELCHAIR" Q
81 .I RMPRLPRO="N" S RMPRLPRO="FOOT CENTER" Q
82 .I RMPRLPRO="D" S RMPRLPRO="DDC" Q
83 ;form requested on
84 S FRM=$P(Y,U,13),REM=$P(Y,U,18)
85 S DATE=$E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_$E(DATE,2,3)
86 S TYPE=$P($G(^RMPR(660,AN,1)),U,4)
87 ;S TYPE=$S(TYPE="":"",$D(^RMPR(661,TYPE,0)):$P(^(0),U,1),1:"")
88 S AMIS=$P(Y,U,15),VEN=$S(VEN="":"",$D(^PRC(440,VEN,0)):$P(^(0),U,1),1:"")
89 I $D(^RMPR(660.1,"AC",AN)),$P(^RMPR(660.1,$O(^RMPR(660.1,"AC",AN,0)),0),U,11)]"" S AMIS=AMIS_"+"
90 S TRANS=$S(TRANS]"":TRANS,1:""),TRANS1="" S:TRANS="X" TRANS1=TRANS,TRANS=""
91 S DEL=$E(DEL,4,5)_"/"_$E(DEL,6,7)_"/"_$E(DEL,2,3) S:DEL="//" DEL=""
92 W !,RK,". ",DATE,?13,QTY,?17
93 W AMIS_$S(TYPE'="":$E($P($G(^RMPR(661.1,TYPE,0)),U,2),1,10),$P(Y,U,26)="D":"DELIVERY",$P(Y,U,26)="P":"PICKUP",$P(Y,U,17):"SHIPPING",1:"")
94 ;W AMIS_$S(TYPE'="":$E($P(^PRC(441,TYPE,0),U,2),1,10),$P(Y,U,26)="D":"DELIVERY",$P(Y,U,26)="P":"PICKUP",$P(Y,U,17):"SHIPPING",1:"")
95 ;historical item
96 I TYPE=""&($D(^RMPR(660,$P(IT(RK),U,1),"HST"))) W $E($P(^("HST"),U,1),1,10)
97 W ?30,TRANS,?31,TRANS1
98 ;display source of procurement for 2529-3 under vendor header
99 I $D(RMPRLPRO) W ?33,RMPRLPRO
100 I '$D(RMPRLPRO),VEN'="" W ?33,$E(VEN,1,10)
101 K RMPRLPRO
102 W:$D(^RMPR(660,$P(IT(RK),U,1),"HST")) $E($P(^("HST"),U,3),1,10)
103 I STA'="" D
104 .S DIC="^DIC(4,",DIQ(0)="E",DR=99,DIQ="RMPRSTN",DA=STA D EN^DIQ1
105 .W:$D(RMPRSTN(4,STA,99,"E")) ?45,RMPRSTN(4,STA,99,"E")
106 W ?50,$E(SN,1,9),?60,DEL
107 I $P(IT(RK),U,3) S CST=$P(IT(RK),U,3)
108 W ?71,$J($FN($S(CST'="":CST,$P(RMYSAV,U,17):$P(RMYSAV,U,17),1:""),"T",2),9)
109 W:REM]"" !,?3,REM
110 I $P(IT(RK),U,2)="" S $P(IT(RK),U,2)=RZ
111 Q
112OVER ;
113 N ANS
114 S RZ=RK W !,"+=Turned-In *=Historical Data I=Initial X=Repair S=Spare R=Replacement",!,"Enter 1-",RK," to show full entry, '^' to exit or `return` to continue. " R ANS:DTIME S:'$T ANS="^"
115 I ANS="^^" S ANS="^" G ASK1^RMPOPAT Q
116 I ANS="^" G ASK1^RMPOPAT Q
117 I ANS="",RK+1'>RC&($G(IT(RK+1))) D HDR Q
118 I ANS="" Q
119 I ANS'?1N.N!(ANS>RK)!(+ANS=0)!(+ANS'=ANS) W $C(7),!," Must be between 1 and ",RK," to be valid" G OVER
120 I ANS>0,(ANS<(RK+1)) S AN=ANS,RZ=RK D ^RMPOPAT3
121 S RK=$P(IT(ANS),U,2)
122 Q
123HDR ;Print Header, Screen 4
124 W @IOF
125 S PAGE=3
126 W !,$E(RMPRNAM,1,20),?23,"SSN: "
127 W $E(RMPRSSN,1,3)_"-"_$E(RMPRSSN,4,5)_"-"_$E(RMPRSSN,6,10)
128 W ?42,"DOB: "
129 S Y=RMPRDOB X ^DD("DD") W Y K Y
130 W ?61,"CLAIM# ",$G(RMPRCNUM)
131 W !?4,"Date",?12,"Qty",?19,"HCPCS",?28,"Type",?34,"Vendor",?45,"Sta",?50,"Serial",?58,"Delivery Date",?72,"Tot Cost"
132 Q
Note: See TracBrowser for help on using the repository browser.