source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRED5.m@ 1764

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

initial load of FOIAVistA 6/30/08 version

File size: 3.9 KB
Line 
1RMPRED5 ;HIN/RVD-EDIT ISSUE FROM STOCK UTILITY;2/1/1999
2 ;;3.0;PROSTHETICS;**33,41,53**;Feb 09, 1996
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5NHCPC(RX) ;HCPCS, location or psas/item different
6 D NEWVAR
7 D RMVAR
8 I $G(RO),$G(RHO) D
9 .S RMHCPC=RHO,RL=RO
10 .S:$G(RMHCPC)&$G(RL) RMHCDA=$$RMHC
11 .S RMQTY=RQO*-1,RMIT=RIO
12 .I RH'=RHO,$G(RMSTOCK) S $P(^RMPR(661.2,RMSTOCK,0),U,2)="",$P(^(0),U,13)=RMDESC
13 D:$G(RMHCDA) UPD
14 S (RMHCDA,RD6612)=""
15 I $G(RN),$G(RH) D
16 .S RMHCPC=RH,RL=RN
17 .S:$G(RMHCPC)&$G(RL) RMHCDA=$$RMHC
18 .S RMQTY=RQ,RMIT=RI S:(RH'=RHO) RSO=RSOUR,RDF=RF
19 D:$G(RMHCDA) UPD
20 S:$G(RL) $P(^RMPR(660,RMPRIEN,1),U,5)=RD6612
21 I $G(RH)'=$G(RHO) S $P(^RMPR(660,RMPRIEN,1),U,2)=RDES
22 D SETC
23 Q
24 ;
25QTYN(RX) ;change quantity
26 D NEWVAR
27 D RMVAR
28 S RMHCPC=RH,RL=RN
29 S:$G(RMHCPC)&$G(RL) RMHCDA=$$RMHC
30 S RMQTY=RQ-RQO,RMIT=RI
31 S RDF=RF,RSO=RSOUR
32 D:$G(RMHCDA) UPD
33 S:$G(RL) $P(^RMPR(660,RMPRIEN,1),U,2)=RDES
34 D SETC
35 Q
36 ;
37NEWVAR N X,Y,RMQTY,RMIT,RMHCPC,RMHCDA,RMLOC
38 N RD6612,RMBA,RBAL,RAVA,RAV,RSOUR,RSO
39 Q
40 ;
41RMVAR ;piece array variable
42 S (RDF,RSO)=""
43 S RN=$P(RX,"^",1)
44 S RH=$P(RX,"^",2)
45 S RHO=$P(RX,"^",3)
46 S RO=$P(RX,"^",4)
47 S RI=$P(RX,"^",5)
48 S RIO=$P(RX,"^",6)
49 S RQ=$P(RX,"^",7)
50 S RQO=$P(RX,"^",8)
51 S RSOUR=$P(RX,"^",9)
52 S RF=$P(RX,"^",10)
53 S RMDESC="Edited/Returned STOCK ISSUE"
54 Q
55 ;
56RMHC() ; get HCPCS IEN in #661.3
57 N Y
58 S Y=$O(^RMPR(661.3,RL,1,"B",RMHCPC,0))
59 Q Y
60 ;
61UPD ;update Pros Inventory balance.
62 Q:'$G(RMHCDA)!'$G(RL)!'$D(RMIT)
63 S:$D(^RMPR(661.3,RL,1,RMHCDA,0)) RMITDA=$O(^RMPR(661.3,RL,1,RMHCDA,1,"B",RMIT,0))
64 Q:'$G(RMITDA)
65 S (RBAL,RCOS)=0 D
66 .S RMBA=$P(^RMPR(661.3,RL,1,RMHCDA,1,RMITDA,0),U,2),RBAL=RMBA-RMQTY
67 .S RMCO=$P(^RMPR(661.3,RL,1,RMHCDA,1,RMITDA,0),U,3)
68 .S (RAVA,RAV)=$P(^RMPR(661.3,RL,1,RMHCDA,1,RMITDA,0),U,10)
69 .S $P(^RMPR(661.3,RL,1,RMHCDA,1,RMITDA,0),U,2)=RBAL
70 .S $P(^RMPR(661.3,RL,1,RMHCDA,1,RMITDA,0),U,3)=RBAL*RAV
71 S RMDAHC=RMHCPC
72 D BAL^RMPR5NU1
73 S X=DT,DIC(0)="AEQL",DLAYGO=661.2,DIC="^RMPR(661.2," K DD,DO
74 D FILE^DICN K DLAYGO S RMCOM="Edited/Returned STOCK ISSUE" ;("_RMQTY_")"
75 S ^RMPR(661.2,+Y,0)=DT_"^"_RDF_"^"_RSO_"^"_RMDAHC_"^^^"_DUZ_"^"_RMQTY_"^"_RMIT_"^^^"_RMTOBA_"^"_RMCOM_"^"_$J(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RL_"^"_RAVA
76 S (RD6612,DA)=+Y,DIK=DIC D IX1^DIK
77 Q
78 ;
79SETC ;
80 K ^RMPR(660,"AD",$P(R12(0),U,6),RMPRIEN) K:$P(R12(0),U,12)'="" ^RMPR(660,"CT",$P(R12(0),U,12),RMPRIEN)
81 Q
82 ;
83CHK ;check for source and type of transaction changes.
84 S RMCPTOLD=$P(R1(1),U,6),RMSONEW=$P(R1(0),U,14),RMTYNEW=$P(R1(0),U,4)
85 Q:'$G(RMHCPC)
86 S RMCPT1=$G(^RMPR(661.1,RMHCPC,4))
87 I (RMSONEW="C"),(RMCPTOLD["UE"),(RMCPT1["NU") D SOUC
88 I (RMSONEW="C"),(RMCPTOLD'["RR"),(RMCPTOLD'["NU"),(RMCPT1["NU") S $P(R1(1),U,6)=RMCPTOLD_",NU"
89 I (RMSONEW="C"),(RMCPTOLD["RR") S RMRR="NU" D DELRPRR
90 I (RMSONEW="V"),(RMCPTOLD["RR") S RMRR="RR" D DELRPRR
91 I (RMSONEW="V"),(RMCPTOLD["NU"),(RMCPT1["UE") D SOUV
92 I (RMSONEW="V"),(RMCPTOLD'["NU"),(RMCPTOLD'["UE"),(RMCPT1["UE") S $P(R1(1),U,6)=RMCPTOLD_",UE"
93 I ((RMTYNEW="R")!(RMTYNEW="X")),(RMCPTOLD'["RP"),(RMCPT1["RP") D ADDRP
94 I ((RMTYNEW="I")!(RMTYNEW="S")),(RMCPTOLD["RP") S RMRR="RP" D DELRPRR
95 Q
96SOUC ;logic for updating SOURCE change for commercial.
97 F RMCI=1:1 S RMC=$P(RMCPTOLD,",",RMCI) I RMC="UE" S $P(RMCPTOLD,",",RMCI)="NU" S $P(R1(1),U,6)=RMCPTOLD Q
98 Q
99 ;
100SOUV ;logic for updating SOURCE change for VA.
101 F RMCI=1:1 S RMC=$P(RMCPTOLD,",",RMCI) I RMC="NU" S $P(RMCPTOLD,",",RMCI)="UE" S $P(R1(1),U,6)=RMCPTOLD Q
102 Q
103 ;
104DELRPRR ;logic for deleting 'RP' or 'RR' modifier with transaction change.
105 F RMCI=1:1:8 S RMC=$P(RMCPTOLD,",",RMCI) I RMC=RMRR S $P(RMCPTOLD,",",RMCI)="" D
106 .S RMF=$F(RMCPTOLD,",,"),RMFPIECE=$E(RMCPTOLD,1,RMF-2)
107 .S RMLPIECE=$E(RMCPTOLD,RMF,32),RMCPTOLD=RMFPIECE_RMLPIECE,RMCLEN=$L(RMCPTOLD)
108 .I $E(RMCPTOLD,1)="," S RMCPTOLD=$E(RMCPTOLD,2,RMCLEN)
109 .I $E(RMCPTOLD,RMCLEN)="," S RMCPTOLD=$E(RMCPTOLD,1,RMCLEN-1)
110 .S $P(R1(1),U,6)=RMCPTOLD
111 K RMRR Q
112 ;
113ADDRP ;logic for adding 'RP' modifier with transaction change.
114 S RMCPTOLD=RMCPTOLD_",RP" S $P(R1(1),U,6)=RMCPTOLD
115 Q
Note: See TracBrowser for help on using the repository browser.