source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR37A.m

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

initial load of WorldVistAEHR

File size: 1.7 KB
Line 
1RMPR37A ;PHX/JLT-CONTINUATION OF POST 2237 TO 10-2319 RMPR37 ;8/29/1994
2 ;;3.0;PROSTHETICS;;Feb 09, 1996
3A ;DISPLAY ITEMS INFORMATION ON 2237
4 Q:'$D(R410("IT")) W !?5,ITN,">"
5 S D1=0 F I=0:0 S D1=$O(R410("IT",ITN,1,D1)) Q:D1'>0 W ?10,$P(R410("IT",ITN,1,D1,0),U,1),!
6 D A1
7 K R1,RZZZ,QT,CT Q
8A1 S RTN=R410("IT",ITN,0)
9 W ?10,"QTY: ",$P(RTN,U,2),?20,"UNIT OF ISSUE: "
10 S UN=$P(RTN,U,3)
11 W:+UN $P(^PRCD(420.5,UN,0),U,1)
12 W ?40,"UNIT COST:"
13 S (X,CT)=$P(RTN,U,7),X2="2$" D COMMA^%DTC
14 W X,!
15 S QT=$P(RTN,U,2),CTT=CTT+(CT*QT)
16 Q
17NUM ;CHECK FOR ITEMS BY NUMBER ENTRY
18 I $D(^RMPR(661,"B",RMPRY)) S X=RMPRY,DIC(0)="NMZ",DIC=441 D ^DIC I +Y S RIT(RMPRY,$P(Y(0),U,2))=""
19 I '$D(R410("IT",RMPRY,1))&($D(RIT)) Q
20 I '$D(R410("IT",RMPRY,1)) W $C(7),"??" Q
21 F RI=0:0 S RI=$O(R410("IT",RMPRY,1,RI)) Q:RI'>0 S RZ=R410("IT",RMPRY,1,RI,0) I RZ'="" D EXT
22 Q
23EXT S (CI,C1)=1,GI=$L(RZ,",")
24 I GI>0 F I=1:1:GI-1 S RAT=$F(RZ,",") S RZ=$E(RZ,1,RAT-2)_" "_$E(RZ,RAT,99)
25 F RT=1:1 S RE=$E(RZ,RT) Q:$A(RE)'>0 I $A(RE)=32 S CI=CI+1
26 F RT=1:1:CI S RD=$P(RZ," ",RT) S:$L(RD)>2 RD(RD)=RD
27 D PAR Q
28CHK ;CHECK FOR ITEMS IN 661 BY SHORT DESCRIPTION X-REF
29 S AZL=$L(RMPRY)
30 I $D(^PRC(441,"C",RZ)) F RG=0:0 S RG=$O(^PRC(441,"C",RZ,RG)) Q:RG'>0 S:$D(^RMPR(661,"B",RG)) RIT(RG,RZ)="" G:'$D(^RMPR(661,"B",RG)) EXT
31 S RD(RZ)="" G EXT
32PAR S RXX="" F RF=0:0 S RXX=$O(RD(RXX)) Q:RXX="" I $D(^PRC(441,"C",RXX)) F RNI=0:0 S RNI=$O(^PRC(441,"C",RXX,RNI)) Q:RNI'>0 I $D(^RMPR(661,"B",RNI)) S RIT(RNI,RXX)=""
33 S RB="" F RF=0:0 S RB=$O(RD(RB)) Q:RB="" S:RMPRY AZL=3 S RJ=$E(RB,1,AZL) F KK=0:0 S RJ=$O(^PRC(441,"C",RJ)) Q:$E(RB,1,AZL)'=$E(RJ,1,AZL) F RIN=0:0 S RIN=$O(^PRC(441,"C",RJ,RIN)) Q:RIN'>0 I $D(^RMPR(661,"B",RIN)) S RIT(RIN,RJ)=""
34 Q
Note: See TracBrowser for help on using the repository browser.