source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIYO.m@ 1036

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

initial load of WorldVistAEHR
File size: 4.5 KB
RevLine 
[613]1RMPRPIYO ;HIN/RVD-PROS INVENTORY ORDER/RE-ORDER ;5/7/01
2 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
3 D DIV4^RMPRSIT I $D(Y),(Y<0) K DIC("B") Q
4 S X="NOW" D ^%DT D DD^%DT S RMDAT=Y
5 ;
6 W @IOF
7 ;ask for location
8 W !!,"Ordering ITEM from Supply or Vendor....",!
9 ;
10HCPC ;ask for HCPCS
11 S RMF=1
12 K DTOUT,DUOUT,DIC
13 S DIC("A")="Select HCPCS to ORDER: "
14 ;
15 S DIC="^RMPR(661.11,",DIC(0)="AEMNQ"
16 S DIC("S")="S RZ=^RMPR(661.11,+Y,0),RH=$P(RZ,U,1),RI=$P(RZ,U,2),RT=$P(RZ,U,9),RE=$O(^RMPR(661.1,""B"",RH,0)) I $P(^RMPR(661.1,RE,0),U,5),RT'=1,($P(RZ,U,4)=RMPR(""STA""))"
17 S DIC("W")="I $D(^RMPR(661.11,+Y,0)) S RMZ=^RMPR(661.11,+Y,0) W "" "",$P(RMZ,U,7),"" "",$P(RMZ,U,3)"
18 W ! D ^DIC I $D(DUOUT)!$D(DTOUT)!(Y<0) G EXIT
19 S RMHCPC=$P(^RMPR(661.11,+Y,0),U,1)
20 S RMIDA=$P(^RMPR(661.11,+Y,0),U,2)
21 S RMHCDA=$O(^RMPR(661.1,"B",RMHCPC,0))
22 S RMPR11("HCPCS")=RMHCPC
23 S RMPR11("ITEM")=RMIDA
24 S RMPR11("STATION")=RMPR("STA")
25 ;
26VEN ;order item from vendor.
27 K DIR,Y S DIR(0)="661.41,4",DIR("A")="Enter Vendor" D ^DIR
28 I $D(DUOUT)!$D(DTOUT) W !,"*** Item was not ordered...." H 1 G HCPC
29 I X="" W $C(7),!,"Enter Vendor from the Vendor file.." G VEN
30 S RMVEN=+Y K DIR,Y
31 ;
32 ;
33ORDER ;order QUANTITY from vendor or supply.
34 K DIR,Y S DIR(0)="661.41,7",DIR("A")="Quantity to Order" D ^DIR
35 I $D(DUOUT)!$D(DTOUT) W !,"*** Item was not ordered...." H 1 G HCPC
36 I X="" W $C(7),!,"Enter quantity 1 to 99999.." G ORDER
37 S (RMPR6("QUANTITY"),RMORDER)=Y K DIR,Y
38 ;
39COM ;comments
40 K DIR,Y S DIR(0)="661.41,9",DIR("A")="Enter Comment" D ^DIR
41 I $D(DUOUT)!$D(DTOUT) G HCPC
42 S (RMPR6("COMMENT"),RMCOM)=Y
43SET6 ;set-up 661.6 data
44 S RMPR6("VENDOR")=$G(RMVEN)
45 S RMPR6("TRAN TYPE")=2
46 S RMPR6("LOCATION")=""
47 S RMPR6("USER")=$G(DUZ)
48 S RMPR6("VALUE")=""
49UP6 ;create file 661.6
50 S RMERR=$$CRE^RMPRPIX6(.RMPR6,.RMPR11)
51 I $G(RMERR) W !,"*** Error in file 661.6 update!!!",! H 2 G HCPC
52UPD ;update file 661.41
53 ;
54 ;D UPDATE^DIE("","RMDAT","","RMERR")
55 ;call API for 661.41
56 L +^RMPR(661.41,"ASSHID",RMPR("STA"),"O",RMPR11("HCPCS"),RMPR11("ITEM"))
57 K RMERR,RMERROR
58 S DIE="^RMPR(661.41,"
59 S RMDAT(661.41,"+1,",.01)=DT
60 S RMDAT(661.41,"+1,",1)=RMPR11("ITEM")
61 S RMDAT(661.41,"+1,",2)=RMPR("STA")
62 S RMDAT(661.41,"+1,",4)=RMVEN
63 S RMDAT(661.41,"+1,",5)=RMPR11("HCPCS")
64 S RMDAT(661.41,"+1,",7)=RMORDER
65 S RMDAT(661.41,"+1,",9)=RMCOM
66 S RMDAT(661.41,"+1,",10)="O"
67 D UPDATE^DIE("","RMDAT","","RMERR") I $D(RMERR) S RMERROR=1
68 L -^RMPR(661.41,"ASSHID",RMPR("STA"),"O",RMPR11("HCPCS"),RMPR11("ITEM"))
69 I $G(RMERROR) W !,"*** Error in file 661.41 update!!!",!
70 I '$G(RMERROR) W !,"*** Item was ordered...."
71 H 1 G HCPC
72 ;
73 ; Prompt if adding a new HCPCS Item
74OKADD(RMPR11,RMPRYN,RMPREXC) ;
75 N DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT
76 S RMPREXC="",DIR(0)="Y"
77 S DIR("A")="Are you adding '"_RMPR11("DESCRIPTION")_"' as a new ITEM for this HCPCS"
78 D ^DIR
79 I $D(DTOUT) S RMPREXC="T" G ADDNMX
80 I $D(DIROUT) S RMPREXC="P" G ADDNMX
81 I X=""!(X["^") S RMPREXC="^" G ADDNMX
82 S RMPRYN="N" S:Y RMPRYN="Y"
83 S RMPREXC=""
84ADDNMX Q
85 ;
86LIKE(RMPRSTN,RMPRHCPC,RMPRTXT,RMPREXC,RMPR11) ;
87 N RMPRMAX,RMPRLIN,RMPRGBL,DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRA
88 N RMPRERR,RMPRN
89 S RMPREXC="",RMPRMAX=19
90 S RMPRGBL="^RMPR(661.11,"_"""ASHD"","_RMPRSTN_","""_RMPRHCPC_""","""_RMPRTXT_""")"
91 I $D(^RMPR(661.11,"ASHI",RMPRSTN,RMPRHCPC,RMPRTXT)) D G LIKEA
92 . S RMPRA(1)=$O(^RMPR(661.11,"ASHI",RMPR("STA"),RMPRHCPC,RMPRTXT,""))
93 . W !?5,1,?9,$P(^RMPR(661.11,RMPRA(1),0),"^",2)
94 . Q
95LIKEA1 K RMPRA S RMPRLIN=0
96LIKEA S RMPRGBL=$Q(@RMPRGBL)
97 I '$D(RMPRLIN) S RMPRLIN=0
98 I RMPRGBL="" G LIKEB
99 I $QS(RMPRGBL,1)'=661.11 G LIKEB
100 I $QS(RMPRGBL,2)'="ASHD" G LIKEB
101 I $QS(RMPRGBL,3)'=RMPR("STA") G LIKEB
102 I $QS(RMPRGBL,4)'=RMPRHCPC G LIKEB
103 I $E($QS(RMPRGBL,5),1,$L(RMPRTXT))'=RMPRTXT G LIKEB
104 S RMPRLIN=RMPRLIN+1
105 W !?4,$J(RMPRLIN,2),?9,$QS(RMPRGBL,5)
106 S RMPRA(RMPRLIN)=$QS(RMPRGBL,6)
107 I RMPRLIN'<RMPRMAX G LIKEB
108 G LIKEA
109LIKEB I RMPRLIN=0 G LIKEX
110 S DIR(0)="NAO^1:"_RMPRLIN_": ",DIR("A")="CHOOSE 1-"_RMPRLIN_": "
111 D ^DIR W !
112 I $D(DTOUT) S RMPREXC="T" G LIKEX
113 I $D(DIROUT) S RMPREXC="P" G LIKEX
114 I X="" S RMPREXC="" G LIKEX
115 I X["^"!$D(DUOUT) S RMPREXC="^" G LIKEX
116 K RMPR11
117 S RMPR11("IEN")=RMPRA(X),RMPRERR=$$GET^RMPRPIX1(.RMPR11)
118LIKEX Q
119 ;
120LKP ;print a message if PSAS HCPCS not in PIP or invalid HCPCS.
121 Q:'$G(RMF)!(X=" ")
122 S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
123 K RX
124 I $D(^RMPR(661.7,"XSHIDS",RMPR("STA"),X)) S RX=1
125 I '$G(RX),$D(^RMPR(661.1,"B",X)) D EN^DDIOL("*** Only PSAS HCPCS in PIP can be ordered. Please verify your Location and PSAS HCPCS!!","","!!")
126 K RX
127 Q
128 ;
129EXIT ;MAIN EXIT POINT
130 N RMPRSITE,RMPR D KILL^XUSCLEAN
131 Q
Note: See TracBrowser for help on using the repository browser.