source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29LU.m@ 1700

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

initial load of FOIAVistA 6/30/08 version
File size: 6.6 KB
Line 
1RMPR29LU ;HIN/RVD-LAB ISSUE FROM STOCK UTILITY;5/27/1998
2 ;;3.0;PROSTHETICS;**33,37,44**;Feb 09, 1996
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4LIS K ^UTILITY("DIQ1",$J),HLD,DIC
5 S (RMPRDFN,DFN,Y)=$P(^RMPR(664.1,RMPRDA,0),U,2) D DEM^VADPT
6 S RMPRNAM=$P(VADM(1),U),RMPRSSN=$P(VADM(2),U),RMPRDOB=$P(VADM(3),U)
7 Q:$G(RMPRDA)'>0 S DIC="^RMPR(664.1,",DA=RMPRDA,DR=".02;.11;.04;.09;2;4;13;15;19"
8 D EN^DIQ1 K DIQ,DR S PAGE=1,DA=RMPRDA
9 F RI=0:0 S RI=$O(^RMPR(664.1,DA,2,RI)) Q:RI'>0 I $D(^(RI,0)) D
10 .S RM6(RI)=$G(^RMPR(664.1,DA,2,RI,0))
11 .S DIC="^RMPR(664.1,",DR="6"
12 .S DR(664.16)=".01;2;3;8;9;10;7;12;13;14;15;16;17;18",DA(664.16)=RI
13 .S HLD(RI)=$$ITM1^RMPR31U($P(^RMPR(664.1,DA,2,RI,0),U))
14 .D EN^DIQ1 K DIQ,DR
15 I '$D(PNK) D HD^RMPR29W
16 I $D(PNK) D HDC^RMPR29W
17 S RI=0
18ITD ;ITEM DISPLAY
19 S RI=$O(HLD(RI)) I '$G(RI)!$G(RMEXIT) K ^UTILITY("DIQ1"),^UTILITY($J),PNK,DIR Q
20 W !,HLD(RI),?10,$E(^UTILITY("DIQ1",$J,664.16,RI,.01),1,15)
21 W ?27,$E(^UTILITY("DIQ1",$J,664.16,RI,12),1,15),?45,^(2),?50,^(3),?55,^(8),?65,^(9)
22 W !,?10,"HCPCS: ",^UTILITY("DIQ1",$J,664.16,RI,13)
23WP ;WORD PROCESSING FIELD DISPLAY
24 ;D:($Y+8>IOSL) ASK Q:$D(RMEXIT)
25 ;S RWP=$O(^UTILITY("DIQ1",$J,664.16,RI,7,0))
26 ;I RWP'>0 K HLD(RI) K D0 D ADC^RMPR293(RMPRDA,RI) D G ITD
27 S RLOC=^UTILITY("DIQ1",$J,664.16,RI,17)
28 S RGIP=^UTILITY("DIQ1",$J,664.16,RI,18)
29 S RMINVF=$S(RLOC'="":"PROS INVENTORY",RGIP'="":"GIP",1:"OTHER")
30 W:$D(RMINVF) !,?10,"*** ",RMINVF," ***"
31 D:($Y+8>IOSL) ASK
32 G ITD
33 ;
34 ;S X=$G(^UTILITY("DIQ1",$J,664.16,RI,7,RWP))
35 ;K ^UTILITY($J) S DIWL=1,DIWR=60,DIWF="R" D ^DIWP Q
36 ;
37POST I RMPRGIP S PRCP("QTY")=$P(R1(0),U,7)*-1,PRCP("TYP")="R" D ^PRCPUSA
38 I $D(PRCP("ITEM")) W !!,"Error encountered while posting to GIP. Inventory Issue did not post..." H 10 S RMEXIT=1 G EXIT
39 I RMPRG'="" G GGC
40 L +^RMPR(669.9,RMPRSITE,0):999 I $T=0 S RMPRG=DT_99 G GGC
41 S RMPRG=$P(^RMPR(669.9,RMPRSITE,0),U,7),RMPRG=RMPRG-1
42 S $P(^RMPR(669.9,RMPRSITE,0),U,7)=RMPRG L -^RMPR(669.9,RMPRSITE,0)
43GGC S $P(RMPRI("AMS"),U,1)=RMPRG
44 S $P(RLB("D"),U,6)=RMTIME,$P(RLB("D"),U,7)=$J(RMLACO,0,2)
45 S $P(RLB("D"),U,8)=$J(RMPRCOST,0,2),RMTOTC=RMLACO+RMPRCOST
46 S $P(RLB("D"),U,9)=$J(RMTOTC,0,2),$P(RLB("D"),U,11)=DT,RMLAB="Y"
47 S RMHCPC=$P(R1(1),U,4),$P(R1(0),U,13)=15,$P(R1(0),U,16)=""
48 S RMSER=$P(R1(0),U,11),RMQTY=$P(R1(0),U,7) I $D(RMLOC) D ADD^RMPR5NU1
49 W:$D(RMLOC) !!,"Posted to inventory module.."
50 ;posting for employee lab item count
51 I '$D(RMLOC) D
52 .K Y,DD,DO S DIC="^RMPR(661.2,",DIC(0)="L",X=DT,DLAYGO=661.2 D FILE^DICN K DLAYGO S (RM6612,DA)=+Y
53 .S ^RMPR(661.2,DA,0)=DT_"^"_RMPRDFN_"^"_RMSO_"^"_RMHCPC_"^^^"_DUZ_"^^"_$P(^RMPR(661.1,RMHCPC,0),U,1)_"^^^^^^"_RMPR("STA")_"^^"
54 .S:$D(RMLAB) ^RMPR(661.2,DA,1)=RMTIME_"^"_$J(RMLACO,0,2)
55 .S DIK="^RMPR(661.2," D IX1^DIK
56 S DIK="^RMPR(660,",(RM660,DA)=+Y D IX1^DIK K DIC W !!,"Posted to 2319..",!
57 Q
58DEL ;delete status 2529-3
59 K DIR,Y
60 S DIR(0)="Y",DIR("A")="Would you like to Delete this 2529-3 Entry"
61 S DIR("B")="NO" D ^DIR Q:$D(DTOUT)!($D(DUOUT))!(Y=0)
62 ;delete entry in the 2319 record and mark entry in 664.1 as deleted
63 N BO S BO=0
64 F S BO=$O(^RMPR(664.1,RMPRDA,2,BO)) Q:BO'>0 D
65 .S DA=$P(^RMPR(664.1,RMPRDA,2,BO,0),U,5) Q:DA=""
66 .S DIK="^RMPR(660," D ^DIK
67 W !,?5,"Updated 10-2319" K DA,DIK
68 S DIE="^RMPR(664.1,",DA=RMPRDA,DR="16///^S X=""D""" D ^DIE W !,?5,$C(7),"Marked As Deleted..."
69 S RDEL=1
70 Q
71RDL ;delete record
72 ;the record is only deleted from 664.1 when the user creats a new
73 ;W !! S DIR(0)="Y",DIR("A")="Would you like to delete this Request "
74 ;S DIR("B")="NO" D ^DIR Q:$D(DTOUT)!($D(DUOUT))!(Y=0)
75 S DA=0,BO=0 Q:$G(REDIT)
76 F S BO=$O(^RMPR(664.1,RMPRDA,2,BO)) Q:BO'>0 D
77 .S DA=$P(^RMPR(664.1,RMPRDA,2,BO,0),U,5) Q:DA=""
78 .S DIK="^RMPR(660," D ^DIK
79 K DIK,DA S DA=RMPRDA,DIK="^RMPR(664.1,"
80 D ^DIK K DIK W !!,?5,$C(7),"Deleted..."
81 Q
82 ;
83ASK ;
84 K DIR S DIR(0)="E"
85 S DIR("A")="Enter 'Return' to view more Items or '^' to QUIT item listing"
86 D ^DIR I $D(DTOUT)!$D(DUOUT)!(Y=0) S RMEXIT=1 Q
87 W @IOF,RMPR("L")
88 Q
89 ;
90EN4 ;CREATE JOB RECORD
91 S RMPR("REF")=$P(^RMPR(664.1,RMPRDA,0),U,4),$P(^(0),U,20)="",RN=+$P(^(0),U,24)
92 K DA,D0,DD,DO S DIC="^RMPR(664.2,",DIC(0)="LZ",X=$P(^RMPR(664.1,RMPRDA,0),U,13) D FILE^DICN Q:+Y'>0
93 S (RM6642,DA)=+Y,RN=RN+1
94 K DIC,Y F RT=0:0 S RT=$O(^RMPR(664.1,RMPRDA,2,RT)) Q:RT'>0 I $D(^(RT,0)) S DA660=$P(^(0),U,5) I +DA660 D S $P(^RMPR(664.1,RMPRDA,0),U,24)=RN
95 .S $P(^RMPR(660,DA660,"LB"),U,5)=RM6642,DA=DA660,DIE="^RMPR(660,",DR="83///^S X=$P(^RMPR(664.1,RMPRDA,0),U,1)" D ^DIE
96 S $P(^RMPR(664.2,RM6642,0),U,2)=DA660,$P(^(0),U,3)=RMPR("STA"),$P(^(0),U,4)=RN,$P(^(0),U,8)=RMPR("REF") S DA=RM6642,DIK="^RMPR(664.2," D IX1^DIK
97 Q
98EXIT ;COMMON EXIT POINT
99 D:($Y+8>IOSL) ASK Q:$D(RMEXIT)
100 ;S RL=$O(^UTILITY($J,"W",DIWL,0)) I +RL W !,?10,^(RL,0) K ^(0) G EXT
101 K ^UTILITY($J)
102 Q
103HCP(RD0,RD1) ;print HCPCS and GIP or Pros Inventory in -3.
104 Q:'$D(^RMPR(664.1,RD0,2,RD1,0))
105 S R643=$G(^RMPR(664.1,RD0,2,RD1,3))
106 S RPSAITEM=$P(R643,U,3),RPSALOC=$P(R643,U,4)
107 S RPHCPC=$P($G(^RMPR(664.1,RD0,2,RD1,2)),U,1)
108 Q:'$G(RPHCPC)
109 Q:'$D(^RMPR(661.1,RPHCPC,0))
110 S RPGIP=$P($G(^RMPR(664.1,RD0,2,RD1,0)),U,13)
111 W !,?9,"HCPCS: ",$P(^RMPR(661.1,RPHCPC,0),U,1)
112 I $G(RPSALOC),RPSAITEM'="",$D(^RMPR(661.3,RPSALOC,0)) D
113 .S RHDA=$O(^RMPR(661.3,RPSALOC,1,"B",RPHCPC,0)) Q:'$G(RHDA)
114 .S RIDA=$O(^RMPR(661.3,RPSALOC,1,RHDA,1,"B",RPSAITEM,0))
115 .S RIDES=$P($G(^RMPR(661.3,RPSALOC,1,RHDA,1,RIDA,0)),U,8)
116 .W ?26,RIDES
117 I $G(RPSALOC) W !,?9,"*** Pros Inventory ***",?35,"Location: " I $D(^RMPR(661.3,RPSALOC,0)) W $P(^RMPR(661.3,RPSALOC,0),U,1)
118 I '$G(RPSALOC),$G(RPGIP) W !,?9,"*** GIP ***"
119 I '$G(RPSALOC),'$G(RPGIP) W !,?9,"*** OTHER ***"
120 Q
121 ;
122CHK ;CHECK DISABILITY AND ITEMS
123 ;kill record if not all mandatory fields defined
124 K RKILL,RMEXIT,RMEDIT
125 F RCK=1,2,3,4,11,15 I $P(^RMPR(664.1,RMPRDA,0),U,RCK)="" S RKILL=1 S DA=RMPRDA,DIK="^RMPR(664.1," D ^DIK W !!,?5,$C(7),"ALL MANDATORY FIELDS NOT DEFINED FORM 2529-3 DELETED" Q
126 I $D(RKILL) G EXIT^RMPR29LI
127 ;disability code missing
128 K DKILL
129 I '$D(^RMPR(664.1,RMPRDA,1))!('$O(^RMPR(664.1,RMPRDA,1,0))) S DKILL=1
130 F RI=0:0 S RI=$O(^RMPR(664.1,RMPRDA,1,RI)) Q:RI'>0 I $P(^(RI,0),U,1)=""!($P(^(0),U,2)="") S DKILL=1
131 ;item missing
132 K IKILL
133 I '$D(^RMPR(664.1,RMPRDA,2))!('$O(^RMPR(664.1,RMPRDA,2,0))) S IKILL=1
134 F RI=0:0 S RI=$O(^RMPR(664.1,RMPRDA,2,RI)) Q:RI'>0 I $P(^(RI,0),U,1)=""!($P(^(0),U,2)="")!($P(^(0),U,4)="")!($P(^(0),U,7)="")!($P(^(0),U,8)="") S IKILL=1
135ER1 ;error message
136 I $D(DKILL) W $C(7),!!,?5,"2529-3 FORM INCOMPLETE. DISABILITY CODE INFORMATION IS MISSING!!"
137 I $D(IKILL) W $C(7),!!,?5,"2529-3 FORM INCOMPLETE. ITEM INFORMATION IS MISSING!!"
138 I $D(IKILL)!($D(DKILL)) S DIR(0)="Y",DIR("B")="YES" D
139 .S DIR("A")="Would you like to EDIT this 2529-3 Entry"
140 .D ^DIR I $D(DTOUT)!$D(DUOUT)!(Y=0) S RMEXIT=1 Q
141 .S RMEDIT=1
142 ;K DA,DIC,DIK,DIWF,DIWL,DIWR,PAGE,PNK,RCK,RI,RL,RWP,X
143 ;G LAB^RMPR29LI
144 Q
Note: See TracBrowser for help on using the repository browser.