source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIYJ.m@ 623

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

initial load of WorldVistAEHR

File size: 4.0 KB
Line 
1RMPRPIYJ ;HINCIO/RVD-ISSUE FROM STOCK / CONT. ;9/18/02 07:39
2 ;;3.0;PROSTHETICS;**61,128**;Feb 09, 1996
3 ; RVD #61 - pip INVENTORY PHASE IIIa
4 ;
5 ;Per VHA Directive 10-93-142, this routine should not be modified.
6QTY K DIR,Y S DIR(0)="660,5",DIR("B")=1 S:$P(R1(0),U,7) DIR("B")=$P(R1(0),U,7)
7 D ^DIR I $P(R1(0),U,7)'=""&$D(DUOUT) G LIST
8 I $D(DTOUT) X CK2 G ^RMPRPIYI
9 I $D(DIRUT) G ^RMPRPIYI
10 I $G(RMUBA),((RMUBA-Y)<0) D LOWBA^RMPRPIYI G 2^RMPRPIYI
11 I $G(RMITQTY),RMITQTY<Y W !,"Issue quantity exceeds on-hand (",RMITQTY,") for scanned item bar code!!",! G QTY
12 S $P(R1(0),U,7)=Y,$P(R1(0),U,16)=Y*RMPRUCST K DIR
13 ;
14DATE ;delivery date is set to today's date
15 S $P(R1(0),U,12)=DT,Y=DT D DD^%DT S $P(R3("D"),U,12)=Y
16 ;
17SERV ;date of service
18 S Y=DT D DD^%DT S DIR("B")=Y,DIR("A")="DATE OF SERVICE",DIR(0)="660,39"
19 I $G(REDIT) S DIR("B")=$P(R1("D"),U,8)
20 D ^DIR K DIR I $D(DTOUT) X CK2 G ^RMPRPIYI
21 I $D(DUOUT),$G(REDIT) G LIST
22 I (X="")!(X="@") W !,"This field is mandatory!!!",! G SERV
23 S $P(R1(1),U,8)=Y D DD^%DT S $P(R1("D"),U,8)=Y
24 ;
25LI S DIR(0)="660,9" S:$P(R1(0),U,11)'="" DIR("B")=$P(R1(0),U,11)
26 D ^DIR I $D(DTOUT) X CK1 Q
27 G:$D(DUOUT) LIST
28 I X["^" W !,"Jumping not allowed" G LI
29 I $P(R1(0),U,11)'=""&(X="@") S $P(R1(0),U,11)="" W $C(7),!?5,"Deleted..." H 1 G LOT
30 S $P(R1(0),U,11)=X
31 ;
32LOT ;
33 ;
34 K DIR S DIR(0)="660,21" S:$P(R1(0),U,24)'="" DIR("B")=$P(R1(0),U,24)
35 D ^DIR I $D(DTOUT) X CK1 Q
36 G:$D(DUOUT) LIST
37 I X["^" W !,"Jumping not allowed" G LOT
38 I $P(R1(0),U,24)'=""&(X="@") S $P(R1(0),U,24)="" W $C(7),!?5,"Deleted..." H 1 G REMA
39 S $P(R1(0),U,24)=X
40 ;
41REMA ;
42 ;
43 K DIR S DIR(0)="660,16" S:$P(R1(0),U,18)'="" DIR("B")=$P(R1(0),U,18)
44 D ^DIR I $D(DTOUT) X CK1 Q
45 G:$D(DUOUT) LIST
46 I X["^" W !,"Jumping not allowed" G REMA
47 I $P(R1(0),U,18)'=""&(X="@") S $P(R1(0),U,18)="" W $C(7),!?5,"Deleted..." H 1 G LIST
48 S $P(R1(0),U,18)=X
49 ;
50LIST ;ENTRY POINT FOR STOCK ISSUE ROUTINES TO DISPLAY TRANSACTION DATA
51 S RMDAHC=$P(R1(1),U,4)
52 D:$D(RMCPT) CHK^RMPRED5
53 D ^RMPRPIYK
54 K DIR,RQUIT
55 S DIR(0)="SBO^P:POST;E:EDIT;D:DELETE"
56 S DIR("A")="Would you like to POST/EDIT/DELETE this entry"
57 S DIR("B")="P"
58 S DIR("?")="Answer `P` to post the transaction, `E` to edit the transaction,'D' to delete the transaction"
59 D ^DIR K DIR G:Y="P" POST G:Y="D" DEA
60 I Y="E" S REDIT=1 G 1^RMPRPIYI
61 I $D(DIRUT)!$D(DUOUT)!$D(DTOUT) G ^RMPRPIYI
62 ;
63DEA ;
64 K DIR
65 S DIR("A")="Are you sure you want to DELETE this entry"
66 S DIR("B")="N",DIR(0)="Y"
67 D ^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIRUT) X CK Q
68 I Y=1 W !!,$C(7),?50," Deleted..." H 2 K DIR G RES^RMPRPIYI
69 G LIST
70 ;
71POST ;
72 I RMPR699("AMIS GROUPER")'="" G GGC
73 S RMPRAMIS=0
74 S RMPR699("IEN")=RMPRSITE
75 S RMPRAMIS=$$AMGR^RMPRPIX2(.RMPR699)
76 I RMPRAMIS X CK Q
77GGC ;
78 D SETARR(.RMPR60)
79 S RMPRERR=$$ISS^RMPRPIU6(.RMPR60,.RMPR11I,.RMPR5)
80 I RMPRERR=9 D LOWBA^RMPRPIYI G 2^RMPRPIYI
81 I RMPRERR W !,"*** ERROR in API RMPRPIU6, ERROR = ",RMPRERR," !!!" G EXIT
82 S ^TMP($J,"RMPRPCE",660,RMPR60("IEN"))=RMPR699("AMIS GROUPER")_"^"_$G(RMPRDFN)
83 ;
84 W !,"Posted to 2319..." H 3
85 G RES^RMPRPIYI
86 ;
87EXIT ;EXIT FOR STOCK ISSUES
88 N RMPRSITE,RMPR D KILL^XUSCLEAN
89 Q
90 ;
91INV1 I $P(R1(0),U,14)="C" S $P(R1(0),U,16)=RMPRUCST*$P(R1(0),U,7)
92 G QTY
93 ;
94 ; Set up arrays for Stock Issue Transaction
95SETARR(RMPR60) ;
96 K RMPR60
97 S RMPR60("ENTRY DATE")=$P(R1(0),U,1)
98 S RMPR60("PATIENT IEN")=$P(R1(0),U,2)
99 S RMPR60("ISSUE TYPE")=$P(R1(0),U,4)
100 S RMPR60("QUANTITY")=$P(R1(0),U,7)
101 S RMPR60("IFCAP ITEM")=$P(R1(0),U,6)
102 S RMPR60("UNIT")=$P(R1(0),U,8)
103 S RMPR60("VENDOR IEN")=$P(R1(0),U,9)
104 S RMPR60("SERIAL NUM")=$P(R1(0),U,11)
105 S RMPR60("DELIV DATE")=$P(R1(0),U,12)
106 S RMPR60("DATE OF SERVICE")=$P(R1(1),U,8)
107 S RMPR60("SOURCE")=$P(R1(0),U,14)
108 S RMPR60("COST")=$P(R1(0),U,16)
109 S RMPR60("REMARKS")=$P(R1(0),U,18)
110 S RMPR60("LOT NUM")=$P(R1(0),U,24)
111 S RMPR60("HCPCS")=$P(R1(1),U,4)
112 S RMPR60("CPT IEN")=$P(R1(0),U,22)
113 S RMPR60("CPT MOD")=$P(R1(1),U,6)
114 S RMPR60("PAT CAT")=$P(R1("AM"),U,3)
115 S RMPR60("SPEC CAT")=$P(R1("AM"),U,4)
116 S RMPR60("USER")=$P(R1(0),U,27)
117 S RMPR60("SITE IEN")=RMPRSITE
118 S RMPR60("GROUPER")=RMPR699("AMIS GROUPER")
119 S RMPR60("DATE&TIME")=R1("DATE&TIME")
120 Q
Note: See TracBrowser for help on using the repository browser.