source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPOVDC.m@ 1426

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

initial load of FOIAVistA 6/30/08 version
File size: 6.0 KB
Line 
1RMPOVDC ;HINCIO/RVD - HOME OXYGEN VENDOR/HCPCS/FCP UPDATE ;11/03/00
2 ;;3.0;PROSTHETICS;**56**;Feb 09, 1996
3 ;
4 Q
5EXIT N RMPR,RMPRSITE
6 K RQUIT,RMPOXITE
7 D KILL^XUSCLEAN
8 Q
9 ;
10START ;
11 D KEY() G:$G(RQUIT) EXIT
12 D SITE G:'$D(RMPOXITE) EXIT
13 K DIR S RMCNT=0
14 S DIR(0)="S^1:Update VENDOR;2:Update HCPCS;3:Update FCP;4:Update ITEM;5:Update UNIT COST"
15 S DIR("A")="Type of Update",DIR("B")="Update VENDOR" D ^DIR
16 Q:$D(DIRUT)!($D(DTOUT))
17 S RMPRCHA=$S(Y=1:"VEN",Y=2:"HCPCS",Y=3:"FCP",Y=4:"ITEM",Y=5:"COST",1:"RQUIT")
18 D @RMPRCHA
19 D EXIT
20 Q
21 ;
22VEN ;change vendor utility
23 N RI,RJ,RD,RIT,RMSTA,DIE,DA,DIC,Y,X
24 K RMOLDVEN,RMNEWVEN
25 S DIC("A")="Enter Existing Vendor to UPdate: ",DA(1)=RMPOXITE,RMCNT=0
26 S DIC(0)="AEMQZ",DIC="^RMPR(669.9,"_DA(1)_",""RMPOVDR""," D ^DIC
27 Q:Y<0!($$RQUIT) S RMOLDVEN=+Y,DIC("S")="I +Y'=RMOLDVEN"
28 S DIC("A")="Enter NEW Vendor: "
29 D ^DIC Q:Y<0!($$RQUIT) S RMNEWVEN=+Y
30 K DIC,DA
31 ;change vendor in file #665
32 S DIE="^RMPR(665,"
33 W:$D(^PRC(440,RMOLDVEN,0)) !!,"Updating HO template for vendor ",$P(^PRC(440,RMOLDVEN,0),U,1)," to "
34 W:$D(^PRC(440,RMNEWVEN,0)) $P(^PRC(440,RMNEWVEN,0),U,1)," ...."
35 F RI=0:0 S RI=$O(^RMPR(665,RI)) Q:RI'>0!$G(RQUIT) S RD=$G(^RMPR(665,RI,"RMPOA")),RMSTA=$P(RD,U,7),RMIDT=$P(RD,U,3) I RMSTA=RMPOXITE,((RMIDT="")!(RMIDT>DT)) D
36 .F RJ=0:0 S RJ=$O(^RMPR(665,RI,"RMPOC",RJ)) Q:RJ'>0!$G(RQUIT) S RIT=$G(^RMPR(665,RI,"RMPOC",RJ,0)),RMVEN=$P(RIT,U,2) I RMVEN=RMOLDVEN D
37 ..S DA(1)=RI,DIE="^RMPR(665,"_DA(1)_","_"""RMPOC"""_","
38 ..S DA=RJ,DR="1///^S X=RMNEWVEN" D ^DIE S RMCNT=RMCNT+1
39 W !,"** ",RMCNT," Records updated **"
40 Q
41 ;
42FCP ;change FCP utility.
43 N RI,RJ,RD,RIT,RMSTA,DIE,DA,DIC,DIR,Y,X,RMFCP,RMODES,RMNDES
44 N RMOLDFCP
45 S DIC("A")="Enter Existing Fund Control Point to Update: ",DA(1)=RMPOXITE
46 S DIC(0)="AEMQZ",DIC="^RMPR(669.9,"_DA(1)_",""RMPOFCP""," D ^DIC
47 Q:Y<0!($$RQUIT) S RMOLDFCP=+Y,RMODES=$P(Y,U,2)
48 S DIC("A")="Enter NEW Fund Control Point: "
49 S DIC("S")="I +Y'=RMOLDFCP"
50 D ^DIC Q:Y<0!($$RQUIT) S RMNDES=$P(Y,U,2)
51 K DIC,DA
52 ;change FCP in file #665
53 W !!,"Updating HO template for FCP ",RMODES," to ",RMNDES,"......"
54 F RI=0:0 S RI=$O(^RMPR(665,RI)) Q:RI'>0!$G(RQUIT) S RD=$G(^RMPR(665,RI,"RMPOA")),RMSTA=$P(RD,U,7),RMIDT=$P(RD,U,3) I RMSTA=RMPOXITE,((RMIDT="")!(RMIDT>DT)) D
55 .F RJ=0:0 S RJ=$O(^RMPR(665,RI,"RMPOC",RJ)) Q:RJ'>0!$G(RQUIT) S RIT=$G(^RMPR(665,RI,"RMPOC",RJ,0)),RMFCP=$P(RIT,U,6) I RMFCP=RMODES D
56 ..S DA(1)=RI,DIE="^RMPR(665,"_DA(1)_","_"""RMPOC"""_","
57 ..S DA=RJ,DR="5////^S X=RMNDES" D ^DIE S RMCNT=RMCNT+1
58 W !,"** ",RMCNT," Records updated **"
59 Q
60 ;
61HCPCS ; change HCPCS utility.
62 N RI,RJ,RD,RIT,RMSTA,DIE,DA,DIC,DIR,Y,X,RMODES,RMNDES
63 N RMOLDHCP,RMNEWHCP,RMHCPC
64 S DIC("A")="Enter Existing HCPCS to Update: "
65 S DIC(0)="AEMQZ",DIC="^RMPR(661.1," D ^DIC
66 Q:Y<0!($$RQUIT) S RMOLDHCP=+Y,RMODES=$P(^RMPR(661.1,+Y,0),U,1)
67 S DIC("S")="I +Y'=RMOLDHCP"
68 S DIC("A")="Enter NEW HCPCS: "
69 D ^DIC Q:Y<0!($$RQUIT) S RMNEWHCP=+Y,RMNDES=$P(^RMPR(661.1,+Y,0),U,1)
70 K DIC,DA
71 ;change HCPCS in file #665
72 W !!,"Updating HO template for HCPCS ",RMODES," to ",RMNDES,"......"
73 F RI=0:0 S RI=$O(^RMPR(665,RI)) Q:RI'>0!$G(RQUIT) S RD=$G(^RMPR(665,RI,"RMPOA")),RMSTA=$P(RD,U,7),RMIDT=$P(RD,U,3) I RMSTA=RMPOXITE,((RMIDT="")!(RMIDT>DT)) D
74 .F RJ=0:0 S RJ=$O(^RMPR(665,RI,"RMPOC",RJ)) Q:RJ'>0!$G(RQUIT) S RIT=$G(^RMPR(665,RI,"RMPOC",RJ,0)),RMHCPC=$P(RIT,U,7) I RMHCPC=RMOLDHCP D
75 ..S DA(1)=RI,DIE="^RMPR(665,"_DA(1)_","_"""RMPOC"""_","
76 ..S DA=RJ,DR="6////^S X=RMNEWHCP" D ^DIE S RMCNT=RMCNT+1
77 W !,"** ",RMCNT," Records updated **"
78 Q
79 ;
80ITEM ; change ITEM utility.
81 N RI,RJ,RD,RIT,RMSTA,DIE,DA,DIC,DIR,Y,X,RMITEM
82 N RMOITEM,RMNITEM
83 S DIC("A")="Enter Existing ITEM to Update: "
84 S DIC(0)="AEMQZ",DIC="^RMPR(661," D ^DIC
85 Q:Y<0!($$RQUIT) S RMOITEM=+Y,RMOIFIT=$P($G(^RMPR(661,+Y,0)),U,1)
86 S DIC("A")="Enter NEW ITEM: " K X,Y
87 D ^DIC Q:Y<0!($$RQUIT)
88 S RMNITEM=+Y,RMNIFIT=$P($G(^RMPR(661,+Y,0)),U,1)
89 K DIC,DA
90 ;change ITEM in file #665
91 W !!,"Updating HO template for item ",$P($G(^PRC(441,RMOIFIT,0)),U,2)," to ",$P($G(^PRC(441,RMNIFIT,0)),U,2),"......"
92 F RI=0:0 S RI=$O(^RMPR(665,RI)) Q:RI'>0!$G(RQUIT) S RD=$G(^RMPR(665,RI,"RMPOA")),RMSTA=$P(RD,U,7),RMIDT=$P(RD,U,3) I RMSTA=RMPOXITE,((RMIDT="")!(RMIDT>DT)) D
93 .F RJ=0:0 S RJ=$O(^RMPR(665,RI,"RMPOC",RJ)) Q:RJ'>0!$G(RQUIT) S RIT=$G(^RMPR(665,RI,"RMPOC",RJ,0)),RMITEM=$P(RIT,U,1) I RMITEM=RMOITEM D
94 ..S DA(1)=RI,DIE="^RMPR(665,"_DA(1)_","_"""RMPOC"""_","
95 ..S DA=RJ,DR=".01////^S X=RMNITEM" D ^DIE S RMCNT=RMCNT+1
96 W !,"** ",RMCNT," Records updated **"
97 Q
98 ;
99COST ; change UNIT COST utility.
100 N RI,RJ,RD,RIT,RMSTA,DIE,DA,DIC,DIR,Y,X,RMITDES,RMIT,RMITEM,RMIFIT
101 N RMNCOST
102 S DIC("A")="Enter an ITEM for UNIT COST Update: "
103 S DIC(0)="AEMQZ",DIC="^RMPR(661," D ^DIC Q:Y<0!($$RQUIT)
104 S RMIT=+Y,RMIFIT=$P($G(^RMPR(661,RMIT,0)),U,1)
105 I $G(RMIFIT),$D(^PRC(441,RMIFIT,0)) S RMITDES=$P(^PRC(441,RMIFIT,0),U,2)
106 S DIR("A")="Enter new UNIT COST for item "_RMITDES
107 S DIR(0)="667.3,3" D ^DIR Q:Y<0!($$RQUIT) S RMNCOST=+Y
108 K DIC,DA
109 ;change HCPCS in file #665
110 W !!,"Updating HO template for unit cost of item "_RMITDES_" to ",$J(RMNCOST,0,2),"......"
111 F RI=0:0 S RI=$O(^RMPR(665,RI)) Q:RI'>0!$G(RQUIT) S RD=$G(^RMPR(665,RI,"RMPOA")),RMSTA=$P(RD,U,7),RMIDT=$P(RD,U,3) I RMSTA=RMPOXITE,((RMIDT="")!(RMIDT>DT)) D
112 .F RJ=0:0 S RJ=$O(^RMPR(665,RI,"RMPOC",RJ)) Q:RJ'>0!$G(RQUIT) S RIT=$G(^RMPR(665,RI,"RMPOC",RJ,0)),RMITEM=$P(RIT,U,1) I RMITEM=RMIT D
113 ..S DA(1)=RI,DIE="^RMPR(665,"_DA(1)_","_"""RMPOC"""_","
114 ..S DA=RJ,DR="3////^S X=RMNCOST" D ^DIE S RMCNT=RMCNT+1
115 W !,"** ",RMCNT," Records updated **"
116 Q
117 ;
118LJ(S,W,C) ; LEFT JUSTIFY S IN A FIELD W WIDE PADDING WITH CHAR F
119 S C=$G(C," ") ;DEFAULT PAD CHAR IS SPACE
120 S $P(S,C,W-$L(S)+$L(S,C))=""
121 Q S
122 ;
123SITE ; get Home Oxygen site
124 K DIC,DIE,DA,DR,DD,RMPOXITE
125 S DIC="^RMPR(669.9,",DIC(0)="QEAMLZ",DIC("A")="Select SITE: "
126 D ^DIC Q:Y<0!($$RQUIT)
127 S RMPOXITE=+Y
128 Q
129 ;
130KEY() ;user must have the RMPRSUPERVISOR key in order to change
131 ;vendor, HCPCS, FCP and items.
132 N RMKEY
133 S RMKEY=$O(^DIC(19.1,"B","RMPRSUPERVISOR",0))
134 I '$D(^VA(200,DUZ,51,RMKEY)) D Q
135 . W !!,"You do not hold a RMPSUPERVISOR key !!"
136 . S RQUIT=1
137 Q
138 ;
139RQUIT() S RQUIT=$D(DTOUT)!$D(DUOUT)!$D(DIRUT) Q RQUIT
140EQUIT() S RQUIT=$D(DTOUT)!$D(Y) Q RQUIT
Note: See TracBrowser for help on using the repository browser.