source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29LE.m@ 794

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

initial load of FOIAVistA 6/30/08 version
File size: 8.1 KB
Line 
1RMPR29LE ;HIN/RVD-ENTER/CLOSE LAB STOCK ISSUE 2529-3 [ 11/05/98
2 ;;3.0;PROSTHETICS;**33,37**;Feb 09,1996
3CREATE ;CREATE Lab Stock Issue 2529-3
4 K RMPREDIT,RMPRTMP,RMPR25,RMNEW D DIV4^RMPRSIT G:$D(X) EXIT
5 D GETPAT^RMPRUTIL I '$D(RMPRDFN) G EXIT
6 S RMDFN=RMPRDFN
7VIEW ;CREATE Lab Stock Issue 2529-3 VIA LAB MENU
8 N RMPRDA,RMPRWO,RMPRJOB S RMPRF=15,(RSTOCK,RNEW,RFLG)=1 D ^RMPRPAT
9 S DIC="^RMPR(664.1,",DIC(0)="ZL",X=DT
10 S DLAYGO=664.1 D FILE^DICN K DLAYGO,DIC G:+Y'>0 EXIT
11 S RMPRDA=+Y,$P(^RMPR(664.1,RMPRDA,0),U,2)=RMDFN,$P(^(0),U,3)=RMPR("STA"),$P(^(0),U,17)="S"
12 S IDEF=$$STA^RMPR31U(RMPR("STA"))
13 S DA=RMPRDA,DIK="^RMPR(664.1," D IX1^DIK
14 K DR,DA,DIC,Y,DIE D KVAR^VADPT
15 S RMPRDFN=$P(^RMPR(664.1,RMPRDA,0),U,2),VAIP("D")="L"
16 D IN5^VADPT S VAINDT=$P($G(VAIP(3)),U) D INP^VADPT
17EDT ;EDIT/DELETE 2529-3
18 I $G(RMPRDA)>0,$G(RMPRDA)'="" G TYPE
19 K DR,DIC D DIV4^RMPRSIT G:$D(X) EXIT S REDIT=1
20 S DIC="^RMPR(664.1,",DIC(0)="AEQM",DR=".01"
21 ;screen on complete, delete status
22 S DIC("S")="I $P(^(0),U,17)=""S"""
23 S DIC("W")="D EN3^RMPRD1"
24 K DIC("A") D ^DIC K DIC G:+Y'>0 EXIT S RMPRDA=+Y I $G(RMPRDA)'>0 Q
25 L +^RMPR(664.1,RMPRDA,0):1
26 I '$T W $C(7),!!,?5,"Someone is already editing this entry" G EXIT
27 S RMPRDFN=$P(^RMPR(664.1,RMPRDA,0),U,2)
28 D LIS^RMPR29LU K DIR
29 S DIR(0)="Y",DIR("A")="Would you like to Edit this Entry",DIR("B")="NO"
30 D ^DIR G:$D(DTOUT)!($D(DIRUT)) EXIT G:Y=0!(Y<0) EXIT
31 ;D ST^RMPR29LS
32 ;
33TYPE ;
34 K DIR S PDA=RMPRDA
35 D ST^RMPR29LS I '$G(RMPRDFN) W !,"*** UNABLE to access patient information, please contact your IRM..",! G EXIT
36 D GD^RMPR29LS
37 I $G(RNEW),$D(RMFLG) D RDL^RMPR29LU G:$D(RMFLG) EXIT
38 ;G:$D(REDIT) ITEM
39 S DIR(0)="SBO^V:VA;C:COMMERCIAL",DIR("A")="Select VA or COMMERCIAL SOURCE" S DIR("B")="C"
40 S DIR("?")="Enter V for VA or C for Commercial"
41 D ^DIR
42 I $D(DUOUT)!$D(DTOUT) D RDL^RMPR29LU G EXIT
43 S (RMSOR,RMSO)=Y K DIR
44 S DIR(0)="664.16,8"
45TRAN S:$D(RMTYPS) DIR("B")=$S(RMTYPS="I":"INITIAL",RMTYPS="X":"REPAIR",RMTYPS="R":"REPLACE",RMTYPS="S":"SPARE",1:"")
46 D ^DIR
47 I $D(DUOUT)!$D(DTOUT) D RDL^RMPR29LU G EXIT
48 I Y="" W !,"Please enter Type of Transaction!!" G TRAN
49 S RMTYP=Y K DIR
50 S RMTYPS=$S(Y="I":"INITIAL",Y="X":"REPAIR",Y="R":"REPLACE",Y="S":"SPARE",1:"")
51PCAT K DIR S DIR(0)="664.16,9" S:$D(RMCATS) DIR("B")=$S(RMCATS=1:"SC/OP",RMCATS=2:"SC/IP",RMCATS=3:"NSC/IP",RMCATS=4:"NSC/OP",1:"")
52 D ^DIR
53 I $D(DUOUT)!$D(DTOUT) D RDL^RMPR29LU G EXIT
54 I Y="" W !,"Please enter Patient Category!!" G PCAT
55 S RMCAT=Y,RMCATS=$S(Y=1:"SC/OP",Y=2:"SC/IP",Y=3:"NSC/IP",Y=4:"NSC/OP",1:"") K DIR G:RMCAT<4 ITEM
56SCAT S DIR(0)="664.16,10" S:$D(RMSPES) DIR("B")=$S(RMSPES=1:"SPECIAL LEGISLATION",RMSPES=2:"A&A",RMSPES=3:"PHC",RMSPES=4:"ELIGIBILITY REFORM",1:"")
57 I RMCAT=4 D ^DIR I $D(DUOUT)!$D(DTOUT) D RDL^RMPR29LU G EXIT
58 I RMCAT=4 S RMSPE=Y,RMSPES=$S(Y=1:"SPECIAL LEGISLATION",Y=2:"A&A",Y=3:"PHC",Y=4:"ELIGIBILITY REFORM",1:"")
59 K DIR
60ITEM ;EDIT 2529-3 ITEM
61 K DIR,RMEDIT,RMITFLG,DUOUT,DTOUT,DIC,RMPRGIP,RDEL S DA=RMPRDA,DIC="^RMPR(664.1,"_RMPRDA_",2,"
62 S DIC("P")="664.16PA",DA(1)=RMPRDA,DIC(0)="AEQMZL"
63 D ^DIC K DIC G:+Y'>0 LAB
64 S RMITEMS=$P($G(^RMPR(661,$P(Y,U,2),0)),U,1)
65 S (RMIDA,DA)=+Y,DIE="^RMPR(664.1,"_RMPRDA_",2,",DR=".01" D ^DIE I $D(Y)!'$D(^RMPR(664.1,RMPRDA,2,RMIDA,0)) D G ITEM
66 .K ^RMPR(664.1,RMPRDA,2,RMIDA) K DIE,DR,RMIDA S RICHECK=$O(^RMPR(664.1,RMPRDA,2,0))
67 .K:'$G(RICHECK) REDIT
68 I $D(^RMPR(664.1,RMPRDA,2,RMIDA,0)),$P(^RMPR(664.1,RMPRDA,2,RMIDA,0),U,1)="" K ^RMPR(664.1,RMPRDA,2,RMIDA) G ITEM
69 S RM0=$G(^RMPR(664.1,RMPRDA,2,DA,0)) S:$P(RM0,U,2)'="" REDIT=1
70 I $G(REDIT) D
71 .S RMHS=$P($G(^RMPR(664.1,RMPRDA,2,DA,2)),U,1)
72 .S RM3=$G(^RMPR(664.1,RMPRDA,2,DA,3)),RMLOC=$P(RM3,U,4),RMIT=$P(RM3,U,3)
73 .S RMQTYS=$P(RM0,U,2),RMCOS=$P(RM0,U,4),RMGIP=$P(RM0,U,13)
74 .S RMTYPS=$P(RM0,U,7),RMCATS=$P(RM0,U,8),RMSPES=$P(RM0,U,9)
75HCPCS ;HCPCS code
76 K DIC
77 S DIC(0)="AQEM",DIC="^RMPR(661.1,",DIC("A")="PSAS HCPCS: " S:$G(RMHS) DIC("B")=RMHS
78 S DIC("S")="I $P(^RMPR(661.1,+Y,0),U,10)"
79 D ^DIC
80 I $D(DUOUT)!$D(DTOUT) G:$G(REDIT) LAB D RDL^RMPR29LU G EXIT
81 I Y=-1 W !,"HCPCS CODE IS MANDATORY!" D HELP G HCPCS
82 I $P(^RMPR(661.1,+Y,0),U,10)<1 D HELP G HCPCS
83 I +Y>0 G:$P(^RMPR(661.1,+Y,0),U,5)'=1 HCPCS S $P(R1(0),U,22)=$P(^RMPR(661.1,+Y,0),U,4)
84 S (RMI,RMHCPC,DA(1),RMHCPCS)=+Y
85 D ITEMLOC^RMPR5NU1 K DIC
86 I $G(RMITFLG) G:$G(REDIT) LAB D RDL^RMPR29LU G EXIT
87 K:'$G(RMHCDA)!'$G(RMITDA) RMLOC I $G(RMLOC) S RMGIP=0 G VEN
88 G GI
89HMESS1 W !,$C(7),"HCPCS has no pre-determined time....",!,"Please SEND mail message to G.PROS-CODE@FORUM.VA.GOV!!!" X CK Q
90 Q
91 ;
92GI 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 D RDL^RMPR29LU G EXIT
93 S RMPRGIP=$P(^RMPR(669.9,RMPRSITE,0),U,3),RMFORM=15 I RMPRGIP S PRCPPRIV=1 D INV^RMPR29LS G:$D(RMEXIT)&($G(REDIT)) LAB Q:$D(RMEXIT)
94 G:$D(RDEL) ITEM
95 ;
96VEN K DIC("S")
97 ;S X=" ",DIC=440,DIC(0)="ZM" D ^DIC S:+Y>0 DIC("B")=$P(^PRC(440,+Y,0),U,1)
98VEN0 I $G(RMLOC),$D(RMVEN) S DIC("B")=RMVEN
99 S DIC(0)="AEQM",DIC=440,DIC("A")="VENDOR: " S:$G(REDIT)&($D(RMVENS)) DIC("B")=RMVENS D ^DIC
100 I $D(DUOUT)!$D(DTOUT) G:$G(REDIT) LAB D RDL^RMPR29LU G EXIT
101 I +Y'>0 W !!,?5,$C(7),"This is a required response. Enter '^' to exit",! G VEN
102 S (RMVEN,RMVENS)=+Y K DIC,Y,X
103COS ;UNIT COST
104 I (RMSO["C")&($G(RMPRGIP)) S RMCOS=$P($G(^PRCP(445,PRCP("I"),1,PRCP("ITEM"),0)),U,15)
105 I $G(RMLOC) S RMCOS=$P($G(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0)),U,10)
106 S DIR(0)="667.3,3",DIR("A")="UNIT COST"
107 S:$D(RMCOS)&($G(RMCOS)) DIR("B")=RMCOS
108 D ^DIR K DIR
109 I $D(DUOUT)!$D(DTOUT) G:$G(REDIT) LAB D RDL^RMPR29LU G EXIT
110 I (RMSO["C")&(X<.001) W !,"You must enter a UNIT COST....",! G COS
111 S RMCO=Y K DIR
112QTY S DIR(0)="664.16,2",RMQTYS=$P(RM0,U,2) S:$D(RMQTYS) DIR("B")=RMQTYS D ^DIR
113 I $D(DUOUT)!$D(DTOUT) G:$G(REDIT) LAB D RDL^RMPR29LU G EXIT
114 I X<1 W !,"You must enter a quantity....",! G QTY
115 S (RMQTY,RMQTYS)=Y K DIR
116 ;
117 K DIR S DIR(0)="664.16,12",RMSERS=$P(RM0,U,12) S:$D(RMSERS) DIR("B")=RMSERS D ^DIR
118 I $D(DUOUT)!$D(DTOUT) G:$G(REDIT) LAB D RDL^RMPR29LU G EXIT
119 S (RMSER,RMSERS)=Y K DIR
120 S DIE(0)="AEQM",DR=4
121 S DR(1,664.129)="4;"
122 S DR(2,664.1294)=".01"
123 S ^RMPR(664.1,RMPRDA,8,0)="^664.129DA"
124 S ^RMPR(664.1,RMPRDA,8,1,1,0)="^664.1294^"
125 S DA(1)=RMPRDA,DIE="^RMPR(664.1,"_RMPRDA_",8,"
126 S DA=1 D ^DIE K DIE,DR,DA
127 S DA(1)=RMPRDA,DA=RMIDA,DIE="^RMPR(664.1,"_RMPRDA_",2,"
128 S DR="2///^S X=$G(RMQTY);4///^S X=$G(RMCO);12///^S X=$G(RMSER);8///^S X=$G(RMTYP);9///^S X=$G(RMCAT);10///^S X=$G(RMSPE);16///^S X=$G(RMIT);14///^S X=$G(RMSO)"
129 D ^DIE I $D(DTOUT)!$D(DUOUT) G:$G(REDIT) LAB G EXIT
130 S RM0=$G(^RMPR(664.1,RMPRDA,2,DA,0)),RMQTY=$P(RM0,U,2),RMCO=$P(RM0,U,4)
131 I RMQTY S RMTOCO=RMQTY*RMCO,DR="11///^S X=$G(RMTOCO);13///^S X=$G(RMHCPC)" D ^DIE
132 S:$G(RMGIP) $P(^RMPR(664.1,RMPRDA,2,DA,0),U,13)=RMGIP
133 S $P(^RMPR(664.1,RMPRDA,2,DA,3),U,4)=$G(RMLOC)
134 S $P(^RMPR(664.1,RMPRDA,2,DA,3),U,2)=$G(RMVEN)
135 G ITEM
136LAB ;ASK TO POST REQUEST
137 I $G(REDIT),$D(RMIDA) D SET^RMPR29LS
138 S DIR(0)="Y",DIR("A")="Would you like to review this request"
139 S DIR("B")="YES" D ^DIR I $D(DTOUT)!($D(DUOUT)) D CHK^RMPR29LU D:$G(RMEXIT) RDL^RMPR29LU G EXIT
140 I Y=1 S IOP="HOME" D PRT^RMPR29R
141 D CHK^RMPR29LU K RMNEW G:$G(RMEDIT) TYPE D:$G(RMEXIT) RDL^RMPR29LU G:$G(RMEXIT) EXIT
142 K DIR S DIR(0)="Y",DIR("A")="Would you like to post this request"
143 S DIR("B")="YES" D ^DIR G:$D(DTOUT)!($D(DUOUT)) EXIT
144 I +Y=0 W !!,?5,$C(7),"Request not posted!!" D RDL^RMPR29LU G EXIT
145 S RMPRWO=$P(^RMPR(664.1,RMPRDA,0),U,13) G:RMPRWO'="" PRINT S SCR=$P(^(0),U,11)
146 D CR^RMPR29U(SCR) I '$D(RMPRWO) W !!,?5,$C(7),"Request not posted!!" D RDL^RMPR29LU G EXIT
147PRINT D SG^RMPR29LS
148 S DIK="^RMPR(664.1,",DA=RMPRDA D IX1^DIK K DIK,DA
149 W !! S DIR(0)="Y",DIR("A")="Would you like to print this 2529-3 request"
150 S DIR("B")="YES" D ^DIR G:$D(DTOUT)!($D(DUOUT)) EXIT I Y=1 D PRT^RMPR29R
151 ;close a Lab Issue from Stock.
152 D STA^RMPR29LC
153 ;suspense record inquiry
154 D LINK^RMPRS
155 G CREATE
156HELP ;
157 W !,"** You can only select HCPCS that have a LAB pre-determined time.",!,"** If the HCPCS you are selecting are not in the list, please send an E-mail"
158 W !,"** message to G.PROS-CODE@FORUM.VA.GOV to be added in the list..."
159 Q
160 ;
161EXIT ;common exit
162 L:+$G(RMPRDA) -^RMPR(664.1,+RMPRDA,0)
163 ;I '$D(RMPR25)&('$D(RMPREDIT)) W !! S DIR(0)="Y",DIR("A")="Would you like to Process another 2529-3 Request",DIR("B")="NO" D ^DIR G:+Y=1 CREATE
164 N RMPR,RMPRSITE D KILL^XUSCLEAN
165 Q
Note: See TracBrowser for help on using the repository browser.