source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29LC.m@ 1801

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

initial load of WorldVistAEHR
File size: 5.4 KB
RevLine 
[613]1RMPR29LC ;HIN/RVD-LAB ISSUE FROM STOCK ;5/27/1998
2 ;;3.0;PROSTHETICS;**33,37,42**;Feb 09, 1996
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 K RMNEW,RMCLOF,RMEDIT,RMFLG D DIV4^RMPRSIT G:$D(X) EXIT
5STA S RMUSSN=$P($G(^VA(200,DUZ,1)),U,9) I $D(RMUSSN),(RMUSSN'="") S RMPIEN=$O(^PRSPC("SSN",RMUSSN,0))
6 I '$D(RMPIEN) S RMQSAL="*** User is not a valid employee...Please contact Personnel..Transaction not closed." W !!,RMQSAL G EXIT
7 S:RMPIEN RMANSA=$P(^PRSPC(RMPIEN,0),U,29)
8 I '$D(RMANSA) S RMQSAL="*** Employee is not in PAID Employee file...Please check with Personnel..Transaction not closed." W !!,RMQSAL G EXIT
9 I $D(RMANSA),('RMANSA) S RMQSAL="*** Employees' SALARY is missing...Please check with Personnel..Transaction not closed." W !!,RMQSAL G EXIT
10 S:RMANSA RMSAL=(RMANSA/2080)*1.23
11 ;
12SEL G:$G(RSTOCK) COM
13 S DIC="^RMPR(664.1,",DIC(0)="AEMQZ",DIC("S")="I $P(^RMPR(664.1,+Y,0),U,17)=""S""&($P(^(0),U,3)=RMPR(""STA""))"
14 S DIC("W")="D EN3^RMPRD1"
15 D ^DIC G:$D(DTOUT)!$D(DTOUT)!(Y'>0) EXIT
16 L +^RMPR(664.1,+Y):1
17 I '$T W $C(7),!!,?5,"Someone is already editing this entry" G EXIT
18 S RMPRDA=+Y,PAC=1
19 ;
20COM ;COMPLETE 2529-3
21 Q:'$G(RMPRDA) K RMEDIT D LIS^RMPR29LU
22 W !,RMPR("L") K DIR S DIR("A")="Select Processing Action: "
23 S DIR(0)="SAO^1:EDIT 2529-3 ITEM;2:VIEW PATIENT 2319 ;3:PRINT LAB ISSUE FORM;4:RE-DISPLAY ;5:CANCEL 2529-3",DIR("?")="^D HELP^RMPR29W W !,$C(7),?5,""Enter a number 1-5""" D HELP^RMPR29W
24 ;D ^DIR I X="" S PAGE=PAGE+1 D HD^RMPR29W D:$D(^UTILITY($J,"W"))!$O(^UTILITY("DIQ1",$J,664.16,+RI,7,0)) EXT^RMPR29D D ITD^RMPR29D
25 D ^DIR G:$D(DUOUT)!$D(DTOUT) EXIT I X="" G POST
26 I $D(Y),(Y=1) S RMCLOF=1 D TYPE^RMPR29LI G:$D(RMEXIT)!('$D(RMPRDA)) EXIT G COM
27 I $D(Y),(Y=2) S RFLG=1 D ^RMPRPAT G COM
28 I $D(Y),(Y=4) G COM
29 I $D(Y),(Y=5) D DEL^RMPR29LU G:$D(RDEL) SEL G COM
30 I $D(Y),(Y=3) D PRT^RMPR29R G COM
31POST K DIR S DIR(0)="Y",DIR("A")="Do you want to Complete Issuance From Stock",DIR("B")="NO" D ^DIR I +Y=0 W !,"Transaction not completed !!",! Q:$G(RSTOCK) G SEL
32 ;create entry in 664.3
33 S DIC(0)="L",X=DT K RMRPOST
34 S RMPRWO=$P(^RMPR(664.1,RMPRDA,0),U,13)
35 I 'RMPRWO W !,"No Work Order associated with this request...Unable to complete this order...",! G SEL
36 S RMWODA=$O(^RMPR(664.2,"B",RMPRWO,0))
37 I 'RMWODA W !,"No Work Order associated with this request...Unable to complete this order...",! G SEL
38 S RMDAT7=DT_"^"_DT_"^"
39 S ^RMPR(664.1,RMPRDA,7)=RMDAT7
40 S $P(^RMPR(664.1,RMPRDA,0),U,16)=DUZ,RITC=$P(^RMPR(664.1,RMPRDA,2,0),U,4)
41 S RMPRGIP=$P(^RMPR(669.9,RMPRSITE,0),U,3)
42 F RI=0:0 S RI=$O(^RMPR(664.1,RMPRDA,2,RI)) Q:RI'>0 I $D(^(RI,0)) D
43 .S RM0=$G(^RMPR(664.1,RMPRDA,2,RI,0))
44 .S RM3=$G(^RMPR(664.1,RMPRDA,2,RI,3))
45 .S RM660=$P(RM0,U,5),RMWO=$P(RM0,U,6),RMITEM=$P(RM0,U,1),RMQTY=$P(RM0,U,2)
46 .I '$G(RM660) W !,"*** Not posted to 2319, Please edit and repost transaction..",! S RMRPOST=1 H 3 Q
47 .S RMSER=$P(RM0,U,12),RMIT=$P(RM3,U,3),RMSO=$P(RM3,U,1),RMGIP=$P(RM0,U,13)
48 .S RMUNI=$P(RM0,U,3),RMCOST=$P(RM0,U,4),RMTT=$P(RM0,U,7)
49 .S RMLOC=$P(RM3,U,4),(RMHCPC,RMDAHC)=$P($G(^RMPR(664.1,RMPRDA,2,RI,2)),U,1)
50 .I '$G(RMDAHC) W !,"*** Transaction has no HCPCS, Please edit and repost transaction..",! S RMRPOST=1 H 3 Q
51 .S RMTIME=$P(^RMPR(661.1,RMDAHC,0),U,10)/60,RMLACO=RMSAL*RMTIME,RMLACO=$J(RMLACO,0,2)
52 .I $G(RMPRGIP)&($G(RMGIP)) D GIP Q:$D(RMEXIT)
53 .I (RMIT["-")&($G(RMLOC)) D RM6612 ;create entry in 661.2
54 .S RMTOCO=$P(RM0,U,11)
55 .S $P(^RMPR(660,RM660,0),U,12)=DT
56 .S $P(^RMPR(660,RM660,3),U,1)="Veteran"
57 .S $P(^RMPR(660,RM660,0),U,27)=DUZ
58 .S $P(^RMPR(660,RM660,0),U,13)=15
59 .S $P(^RMPR(660,RM660,"LB"),U,6)=RMTIME
60 .S $P(^RMPR(660,RM660,"LB"),U,7)=$J(RMLACO,0,2)
61 .S $P(^RMPR(660,RM660,"LB"),U,8)=$J(RMTOCO,0,2)
62 .S RMTOTC=RMLACO+RMTOCO
63 .S $P(^RMPR(660,RM660,"LB"),U,9)=$J(RMTOTC,0,2)
64 .S $P(^RMPR(660,RM660,"LB"),U,11)=DT
65 .S DIK="^RMPR(660,",DA=RM660 D IX1^DIK
66 .S DIC="^RMPR(664.3,"
67 .K DD,DO,DA,DIK D FILE^DICN
68 .S ^RMPR(664.3,+Y,0)=DT_"^"_RM660_"^"_RMPR("STA")
69 .S DA=+Y,DIK="^RMPR(664.3," D IX1^DIK K DA,DD,DO
70 .S ^RMPR(664.3,+Y,1,0)="^664.33PA^1^1",DA(1)=+Y
71 .S DIC="^RMPR(664.3,"_DA(1)_",1,",DIC(0)="L",X=DUZ
72 .S RMTIME=RMTIME*($G(RITC))
73 .S ^RMPR(664.3,DA(1),1,1,0)=DUZ_"^"_RMTIME_"^"_$J(RMSAL,0,2)_"^"
74 .S DA=1,DIK="^RMPR(664.3,"_DA(1)_",1," D IX1^DIK
75 .S DIE="^RMPR(664.2,",DA=RMWODA,DR="8////^S X=$G(DT);9////^S X=$G(DUZ)" D ^DIE
76 G:$G(RMRPOST) COM
77 S $P(^RMPR(664.2,RMWODA,0),U,10)=DT,DA=RMPRDA G:$D(RMEXIT) EXIT
78 K DA,Y,DIC,X
79 S DA=RMPRDA,DR="24////1;33////^S X=DT;20////^S X=DT",DIE="^RMPR(664.1," D ^DIE I $D(DTOUT)!($D(Y)) G EXIT
80 S:'$P(^RMPR(664.1,RMPRDA,0),U,25) $P(^RMPR(664.1,RMPRDA,0),U,25)=DUZ S $P(^RMPR(664.1,RMPRDA,0),U,26)=DT
81 W !!,?5,$C(7),"Request Completed and Posted!!!" S DIE="^RMPR(664.1,",DR="16///^S X=""C""",DA=RMPRDA D ^DIE
82 S DIK=DIE D IX1^DIK K DIK,DA,DR,DIE
83 Q:$D(RMCOMP)!$G(RSTOCK) G SEL
84 ;END
85 ;
86RM6612 S RMLAB=1
87 S RMHCDA=$O(^RMPR(661.3,RMLOC,1,"B",RMDAHC,0))
88 I 'RMHCDA S RMEXIT=1 Q
89 S RMITDA=$O(^RMPR(661.3,RMLOC,1,RMHCDA,1,"B",RMIT,0))
90 I 'RMITDA S RMEXIT=1 Q
91 D ADD^RMPR5NU1
92 K RMLAB
93 Q
94 ;
95GIP S PRCP("QTY")=RMQTY*-1,PRCP("TYP")="R",PRCP("I")=RMGIP,PRCP("ITEM")=$P($G(^RMPR(661,RMITEM,0)),U,1) D ^PRCPUSA
96 I $D(PRCP("ITEM")) W !!,"Error encountered while posting to GIP. Inventory Issue did not post, Patient 10-2319 not updated!! Please check with your Application Coordinator." H 1 S RMEXIT=1
97 Q
98 ;
99EXIT ;EXIT FOR STOCK ISSUES
100 L:+$G(RMPRDA) -^RMPR(664.1,+RMPRDA,0) K ^UTILITY("DIQ1",$J)
101 ;W !! S DIR(0)="Y",DIR("B")="YES",DIR("A")="Would you like to Complete and Post another 2529-3" D ^DIR G:+Y=1 SEL
102 N RMPR,RMPRSITE D KILL^XUSCLEAN Q
Note: See TracBrowser for help on using the repository browser.