source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRSTK.m

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

initial load of FOIAVistA 6/30/08 version
File size: 7.2 KB
Line 
1RMPRSTK ;PHX/RFM,RVD-ISSUE FROM STOCK ;8/29/1994
2 ;;3.0;PROSTHETICS;**12,13,16,19,21,26,28,33,41,45**;Feb 09, 1996
3 S (RMPRG,RMPRF)=""
4 D HOME^%ZIS W @IOF
5 I '$D(RMPR) D DIV4^RMPRSIT G:$D(X) EXIT^RMPRSTL
6 I $D(RMPRDFN) D LINK^RMPRS
7 D GETPAT^RMPRUTIL G:'$D(RMPRDFN) EXIT^RMPRSTL
8VIEW N RMPRBAC1,RMDES
9 S RMPRBAC1=1 D ^RMPRPAT K RMPRBAC1
10 I $D(RMPRKILL)!($D(DTOUT)) W $C(7),!,"Deleted..." G EXIT^RMPRSTL
11 S CK="W:$D(DUOUT) @IOF,!!!?28,$C(7),""Deleted..."" G EXIT^RMPRSTL"
12 S CK1="W $C(7),!,""Timed-Out, Deleted..."" G EXIT^RMPRSTL"
13 S R3("D")=""
14RES ;ENTRY POINT TO ADD ADDITIONAL ITEMS FOR ISSUE FROM STOCK
15 ;I RMPRG]"" D LINK^RMPRS
16 Q:$G(RMPRDFN)<1
17 K PRCP("ITEM"),DA,DD,DIC,PRC,X,Y,RMSO,RMQTY,RMHCPC,RMLOC,RMLACO,RMITDA,RMINVF,RMSAL
18 S R1(0)=DT_U_RMPRDFN_U_DT,$P(R1(0),U,10)=RMPR("STA"),$P(R1(0),U,27)=DUZ
19 S (R1(1),R3("D"),R4("D"),R1("AM"),RMPRI("AMS"),R1("D"))=""
20 S DIR("?")="Enter V for VA or C for Commercial"
21 S RMINVF="OTHER"
221 ;ENTRY POINT TO EDIT ITEM ON ISSUE FROM STOCK
23 K RMPRGIP,PRCP("ITEM"),RMPRIP,RMITFLG S RMPREVHC=$P(R1(1),U,4)
24 S DIR(0)="SBO^V:VA;C:COMMERCIAL",DIR("A")="Select VA or COMMERCIAL SOURCE" S:$P(R3("D"),U,14)?.A&($P(R3("D"),U,14)'="") DIR("B")=$P(R3("D"),U,14)
25 W @IOF,!?30,RMPRNAM,! D ^DIR I $P(R3("D"),U,14)?1A.A&($D(DUOUT)) G LIST^RMPRSTL
26 I $D(DTOUT) X CK1 Q
27 G:X="" ^RMPRSTK G:$D(DUOUT) ^RMPRSTK I $D(DIRUT) X CK Q
28 S $P(R1(0),U,14)=Y,RMSO=Y K DIR I Y["V" S $P(R1(0),U,16)=0
29 S $P(R3("D"),U,14)=$S(Y="C":"COMMERCIAL",Y="V":"VA",1:"")
30TRAN ;TYPE OF TRANSACTION
31 W ! S DIR(0)="660,2" S:$P(R1(0),U,4)?.E&($P(R3("D"),U,4)'="") DIR("B")=$P(R3("D"),U,4) D ^DIR I $P(R3("D"),U,4)'=""&($D(DUOUT)) G LIST^RMPRSTL
32 I $D(DTOUT) X CK1 Q
33 I $D(DIRUT) X CK Q
34 S $P(R1(0),U,4)=Y K DIR
35 S $P(R3("D"),U,4)=$S(Y="I":"INITIAL ISSUE",Y="X":"REPAIR",Y="R":"REPLACE",Y="S":"SPARE",1:"")
36 ;
37PCAT S DIR(0)="660,62" S:$P(R1("AM"),U,3)?1N.N DIR("B")=$P(R4("D"),U,3) D ^DIR I $P(R1("AM"),U,3)'=""&($D(DUOUT)) G LIST^RMPRSTL
38 I $D(DTOUT) X CK1 Q
39 I $D(DIRUT) X CK Q
40 S $P(R1("AM"),U,3)=Y,$P(R4("D"),U,3)=$S(Y=1:"SC/OP",Y=2:"SC/IP",Y=3:"NSC/IP",Y=4:"NSC/OP",1:"") K DIR
41 I Y<4 S $P(R1("AM"),U,4)="",$P(R4("D"),U,4)="" G 2
42SPE I Y=4 S DIR(0)="660,63" S:$P(R1("AM"),U,4)?1N.N DIR("B")=$P(R4("D"),U,4) D ^DIR I $D(DTOUT) X CK1 Q
43 G:$D(DIRUT) 2
44 I $P(R1("AM"),U,3)=4 S $P(R1("AM"),U,4)=Y,$P(R4("D"),U,4)=$S(Y=1:"SPECIAL LEGISLATION",Y=2:"A&A",Y=3:"PHC",Y=4:"ELIGIBILITY REFORM",1:"")
45 ;
462 S DIC(0)="AEQM",DIC=661 S:$P(R1(0),U,6) DIC("B")=$P(^RMPR(661,$P(R1(0),U,6),0),U) S DIC("A")="ITEM: "
47 K DIC("S") D ^DIC
48 I $P(R3("D"),U,6)&$D(DUOUT) G LIST^RMPRSTL
49 I $D(DUOUT) X CK Q
50 I $D(DTOUT) X CK1 Q
51 I +Y'>0 W !!,?5,$C(7),"This is a required response. Enter '^' to exit",! G 2
52 S $P(R1(0),U,6)=+Y,$P(R3("D"),U,6)=$P(Y,U,2) K DIC,Y,X
53HCPCS ;HCPCS code
54 K DIC
55 S DIC(0)="AEQM",DIC="^RMPR(661.1,",DIC("A")="PSAS HCPCS: " S:$P(R1(1),U,4) DIC("B")=$P(R1(1),U,4) D ^DIC I $P(R1(1),U,4)'=""&($D(DUOUT)) G LIST^RMPRSTL
56 I $D(DTOUT) X CK1 Q
57 I $D(DUOUT) X CK Q
58 I Y=-1 W !,"HCPCS CODE IS MANDATORY!" G HCPCS
59 I +Y>0 G:$P(^RMPR(661.1,+Y,0),U,5)'=1 HCPCS S RMHCPC=+Y
60 S RDA=RMHCPC_"^"_$P(R1(0),U,4)_"^"_$P(R1(0),U,14)_"^"_660
61 D:$D(RMCPT) CHK^RMPRED5
62 W:$G(REDIT) !,"OLD CPT MODIFIER: ",$P(R1(1),U,6)
63 I RMPREVHC'=RMHCPC D CPT^RMPRCPTU(RDA) G:$D(DUOUT)!$D(DTOUT) LIST^RMPRSTL S $P(R1(1),U,6)=$G(RMCPT) W:$G(REDIT) !,"NEW CPT MODIFIER: ",$G(RMCPT)
64 I RMPREVHC'="",(RMPREVHC=RMHCPC),$G(REDIT) D
65 .S DIR(0)="Y",DIR("A")="Would you like to Edit CPT MODIFIER Entry ",DIR("B")="N" D ^DIR Q:$D(DTOUT)!$D(DUOUT)
66 .I $G(Y) D CPT^RMPRCPTU(RDA) Q:$D(DTOUT)!$D(DUOUT) S $P(R1(1),U,6)=$G(RMCPT) W !,"NEW CPT MODIFIER: ",$G(RMCPT)
67 ;
68LOCDIC I $P(^RMPR(661.1,RMHCPC,0),U,9)'=1 S RMINVF="OTHER" K RMLOC,RMITDA
69 I $P(^RMPR(661.1,RMHCPC,0),U,9)=1 D ITEMLOC^RMPR5NU1
70 I $P(R1(1),U,4)'="",$D(DUOUT),$G(RMITFLG) G LIST^RMPRSTL
71 I $P(R1(1),U,4)="",$D(DUOUT) X CK Q
72 I $G(RMLOC),'($G(RMHCDA)&$G(RMITDA)) W !,"PSAS Item was not selected!!" G LOCDIC
73 K DIC
74 G:'$D(RMLOC) GI
75 S RMPRGIP=0 W ! G:RMLOC VEN0
76 ;
77GI I $P(^RMPR(669.9,RMPRSITE,0),U,3),'$D(^PRCP(445,"AD",DUZ)) W $C(7),!,"You are not an authorized user of any Inventory Point, please see your ADPAC." H 2 G EXIT^RMPRSTL
78 S RMPRGIP=$P(^RMPR(669.9,RMPRSITE,0),U,3),RMPRF=$S(+RMPRGIP=0:"11",+RMPRGIP=1:"12"),$P(R1(0),U,13)=RMPRF I RMPRGIP S PRCPPRIV=1 G INV
79 ;
80VEN K DIC("S"),DIC("B")
81 S X=" ",DIC=440,DIC(0)="ZM" D ^DIC S:+Y>0 DIC("B")=$P(^PRC(440,+Y,0),U,1)
82 S RO=0 I $O(^PRC(441,$P(R3("D"),U,6),2,RO))'=""&($P(R1(0),U,9)="") S DIC("B")=$O(^PRC(441,$P(R3("D"),U,6),2,RO))
83 ;
84VEN0 ;set HCPCS when PSAS required fields are set
85 S $P(R1(1),U,4)=RMHCPC,$P(R1(0),U,22)=$P(^RMPR(661.1,RMHCPC,0),U,4)
86 I $P(R3("D"),U,9)'=""&$G(RMITFLG) G LIST^RMPRSTL
87 I $G(RMITFLG) X CK Q
88 I $D(RMLOC),$D(RMVEN),'$D(DIC("B")) S DIC("B")=RMVEN
89 S DIC(0)="AEQM",DIC=440,DIC("A")="VENDOR: " S:$P(R1(0),U,9) DIC("B")=$P(R1(0),U,9) D ^DIC I $P(R3("D"),U,9)'=""&$D(DUOUT) G LIST^RMPRSTL
90 I $D(DTOUT) X CK1 Q
91 I $D(DUOUT) X CK Q
92 I +Y'>0 W !!,?5,$C(7),"This is a required response. Enter '^' to exit",! G VEN
93 S $P(R1(0),U,9)=+Y,$P(R3("D"),U,9)=$P(Y,U,2) K DIC,Y,X
94 G ^RMPRSTL
95 ;
96INV S DIC="^PRCP(445,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,2)=""Y"",$D(^PRCP(445,+Y,4,DUZ,0))" S:$D(RMPRIP) DIC("B")=RMPRIP
97INDIC D ^DIC I $G(REDIT),$D(DUOUT) G LIST^RMPRSTL
98 I $D(DUOUT) X CK Q
99 I $D(DTOUT) X CK1 Q
100 I +Y'>0 W !!,?5,$C(7),"This is a required response. Enter '^' to exit",! G INDIC
101 S (PRCP("I"),RMPRIP)=+Y,PRCP("ITEM")=$P(R3("D"),U,6)
102INVITEM I $D(^PRCP(445,PRCP("I"),1,PRCP("ITEM"),0)) G GIP
103 W !!,"*** ITEM IS NOT IN GIP......."
104 K DIC W ! S DIC="^RMPR(661,"
105 S DIC("S")="S PRCP(""ITEM"")=$P(^(0),U,1) I $D(^PRCP(445,PRCP(""I""),1,PRCP(""ITEM""),0))"
106 S DIC(0)="AEQM",DIC("A")="ITEM: "
107ITDIC D ^DIC I $G(REDIT),$D(DUOUT) G LIST^RMPRSTL
108 I $D(DTOUT) X CK1 Q
109 I $D(DUOUT) X CK Q
110 I +Y'>0 W !!,?5,$C(7),"This is a required response. Enter '^' to exit",! G ITDIC
111 ;
112 S $P(R1(0),U,6)=+Y,$P(R3("D"),U,6)=$P(Y,U,2)
113 S PRCP("ITEM")=$P(R3("D"),U,6) K DIC("S")
114GIP ;gip on
115 S RMPRUCST=0 I $P(R1(0),U,14)["C" S $P(R1(0),U,16)=$P(^PRCP(445,PRCP("I"),1,PRCP("ITEM"),0),U,15),RMPRUCST=$P(R1(0),U,16) I $P(R1(0),U,7) S $P(R1(0),U,16)=$P(R1(0),U,16)*$P(R1(0),U,7)
116 ;if cost is null,0, prompt for cost
117 I RMPRUCST'>0 D
118 .K DIR
119 .S DIR(0)="667.3,3"
120 .S DIR("A")="UNIT COST"
121 .D ^DIR
122 .K DIR
123 .Q:$D(DUOUT)!($D(DTOUT))
124 .S RMPRUCST=Y
125 S RMINVF="GIP"
126V I $P(^PRCP(445,PRCP("I"),0),U,3)="P",+$P(^PRCP(445,PRCP("I"),1,PRCP("ITEM"),0),U,12),$D(^PRC(440,+$P(^(0),U,12),0)),$P(R1(0),U,9)="" S $P(R1(0),U,9)=+$P(^PRCP(445,PRCP("I"),1,PRCP("ITEM"),0),U,12)
127 I $P(^PRCP(445,PRCP("I"),0),U,3)="S" D
128 .I $P(R1(0),U,9)="" K DIC S DIC="^PRCP(445,",DIC(0)="N",X=+$P(^PRCP(445,PRCP("I"),1,PRCP("ITEM"),0),U,12) D ^DIC Q:+Y<0 I $D(^PRCP(445,+Y,1,PRCP("ITEM"),0)) D
129 ..S RMPRVEN=+$P(^PRCP(445,+$P(^PRCP(445,PRCP("I"),1,PRCP("ITEM"),0),U,12),1,PRCP("ITEM"),0),U,12) I $D(^PRC(440,+RMPRVEN,0)) S $P(R1(0),U,9)=RMPRVEN
130 ;
131DEF S X=" ",DIC=440,DIC(0)="ZM" D ^DIC S:+Y>0 DIC("B")=$P(^PRC(440,+Y,0),U,1)
132 G VEN
133 ;
134HCPCG ;HCPCS code with GIP
135 K DIC
136 S DIC(0)="AEQM",DIC="^RMPR(661.1,",DIC("A")="PSAS HCPCS: " S:$P(R1(1),U,4) DIC("B")=$P(R1(1),U,4) D ^DIC
137 I $D(DTOUT) X CK1 Q
138 I $D(DUOUT) X CK Q
139 I Y=-1 W !,"HCPCS CODE IS MANDATORY!" G HCPCG
140 I +Y>0 G:$P(^RMPR(661.1,+Y,0),U,5)'=1 HCPCS S $P(R1(1),U,4)=+Y,$P(R1(0),U,22)=$P(^RMPR(661.1,+Y,0),U,4)
141 S RMHCPC=+Y I $P(^RMPR(661.1,+Y,0),U,9)=1 D ITEMLOC^RMPR5NU1 I '$D(RMLOC) X CK Q
Note: See TracBrowser for help on using the repository browser.