RMPR37A ;PHX/JLT-CONTINUATION OF POST 2237 TO 10-2319 RMPR37 ;8/29/1994
;;3.0;PROSTHETICS;**185**;Feb 09, 1996;Build 19
;
;DDA Patch #185 - Added ECMS ITEMUID information to display
;
A ;DISPLAY ITEMS INFORMATION ON 2237
Q:'$D(R410("IT")) W !?5,ITN,">"
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),!
D A1
K R1,RZZZ,QT,CT,RMPRIUID,RTN,RTN4,UN Q
A1 S RTN=R410("IT",ITN,0),RTN4=""
S:$D(R410("IT",ITN,4)) RTN4=R410("IT",ITN,4)
S RMPRIUID=$P(RTN4,U,3)
W:RMPRIUID'="" ?1,"ECMS ITEM ID: ",RMPRIUID
S:RMPRIUID="" RMPRIUID=RMPR2237_"-"_ITN
I $D(^RMPR(660,"EIID",RMPRIUID)) W " **POSTED to 2319**" S PCT=PCT+1
W !
W ?10,"QTY: ",$P(RTN,U,2),?20,"UNIT OF ISSUE: "
S UN=$P(RTN,U,3)
W:+UN $P(^PRCD(420.5,UN,0),U,1)
W ?40,"UNIT COST:"
S (X,CT)=$P(RTN,U,7),X2="2$" D COMMA^%DTC
W X,!
S QT=$P(RTN,U,2),CTT=CTT+(CT*QT)
Q
NUM ;CHECK FOR ITEMS BY NUMBER ENTRY
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))=""
I '$D(R410("IT",RMPRY,1))&($D(RIT)) Q
I '$D(R410("IT",RMPRY,1)) W $C(7),"??" Q
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
Q
EXT S (CI,C1)=1,GI=$L(RZ,",")
I GI>0 F I=1:1:GI-1 S RAT=$F(RZ,",") S RZ=$E(RZ,1,RAT-2)_" "_$E(RZ,RAT,99)
F RT=1:1 S RE=$E(RZ,RT) Q:$A(RE)'>0 I $A(RE)=32 S CI=CI+1
F RT=1:1:CI S RD=$P(RZ," ",RT) S:$L(RD)>2 RD(RD)=RD
D PAR Q
CHK ;CHECK FOR ITEMS IN 661 BY SHORT DESCRIPTION X-REF
S AZL=$L(RMPRY)
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
S RD(RZ)="" G EXT
PAR 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)=""
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)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR37A 2090 printed Oct 16, 2024@18:33:14 Page 2
RMPR37A ;PHX/JLT-CONTINUATION OF POST 2237 TO 10-2319 RMPR37 ;8/29/1994
+1 ;;3.0;PROSTHETICS;**185**;Feb 09, 1996;Build 19
+2 ;
+3 ;DDA Patch #185 - Added ECMS ITEMUID information to display
+4 ;
A ;DISPLAY ITEMS INFORMATION ON 2237
+1 if '$DATA(R410("IT"))
QUIT
WRITE !?5,ITN,">"
+2 SET D1=0
FOR I=0:0
SET D1=$ORDER(R410("IT",ITN,1,D1))
if D1'>0
QUIT
WRITE ?10,$PIECE(R410("IT",ITN,1,D1,0),U,1),!
+3 DO A1
+4 KILL R1,RZZZ,QT,CT,RMPRIUID,RTN,RTN4,UN
QUIT
A1 SET RTN=R410("IT",ITN,0)
SET RTN4=""
+1 if $DATA(R410("IT",ITN,4))
SET RTN4=R410("IT",ITN,4)
+2 SET RMPRIUID=$PIECE(RTN4,U,3)
+3 if RMPRIUID'=""
WRITE ?1,"ECMS ITEM ID: ",RMPRIUID
+4 if RMPRIUID=""
SET RMPRIUID=RMPR2237_"-"_ITN
+5 IF $DATA(^RMPR(660,"EIID",RMPRIUID))
WRITE " **POSTED to 2319**"
SET PCT=PCT+1
+6 WRITE !
+7 WRITE ?10,"QTY: ",$PIECE(RTN,U,2),?20,"UNIT OF ISSUE: "
+8 SET UN=$PIECE(RTN,U,3)
+9 if +UN
WRITE $PIECE(^PRCD(420.5,UN,0),U,1)
+10 WRITE ?40,"UNIT COST:"
+11 SET (X,CT)=$PIECE(RTN,U,7)
SET X2="2$"
DO COMMA^%DTC
+12 WRITE X,!
+13 SET QT=$PIECE(RTN,U,2)
SET CTT=CTT+(CT*QT)
+14 QUIT
NUM ;CHECK FOR ITEMS BY NUMBER ENTRY
+1 IF $DATA(^RMPR(661,"B",RMPRY))
SET X=RMPRY
SET DIC(0)="NMZ"
SET DIC=441
DO ^DIC
IF +Y
SET RIT(RMPRY,$PIECE(Y(0),U,2))=""
+2 IF '$DATA(R410("IT",RMPRY,1))&($DATA(RIT))
QUIT
+3 IF '$DATA(R410("IT",RMPRY,1))
WRITE $CHAR(7),"??"
QUIT
+4 FOR RI=0:0
SET RI=$ORDER(R410("IT",RMPRY,1,RI))
if RI'>0
QUIT
SET RZ=R410("IT",RMPRY,1,RI,0)
IF RZ'=""
DO EXT
+5 QUIT
EXT SET (CI,C1)=1
SET GI=$LENGTH(RZ,",")
+1 IF GI>0
FOR I=1:1:GI-1
SET RAT=$FIND(RZ,",")
SET RZ=$EXTRACT(RZ,1,RAT-2)_" "_$EXTRACT(RZ,RAT,99)
+2 FOR RT=1:1
SET RE=$EXTRACT(RZ,RT)
if $ASCII(RE)'>0
QUIT
IF $ASCII(RE)=32
SET CI=CI+1
+3 FOR RT=1:1:CI
SET RD=$PIECE(RZ," ",RT)
if $LENGTH(RD)>2
SET RD(RD)=RD
+4 DO PAR
QUIT
CHK ;CHECK FOR ITEMS IN 661 BY SHORT DESCRIPTION X-REF
+1 SET AZL=$LENGTH(RMPRY)
+2 IF $DATA(^PRC(441,"C",RZ))
FOR RG=0:0
SET RG=$ORDER(^PRC(441,"C",RZ,RG))
if RG'>0
QUIT
if $DATA(^RMPR(661,"B",RG))
SET RIT(RG,RZ)=""
if '$DATA(^RMPR(661,"B",RG))
GOTO EXT
+3 SET RD(RZ)=""
GOTO EXT
PAR SET RXX=""
FOR RF=0:0
SET RXX=$ORDER(RD(RXX))
if RXX=""
QUIT
IF $DATA(^PRC(441,"C",RXX))
FOR RNI=0:0
SET RNI=$ORDER(^PRC(441,"C",RXX,RNI))
if RNI'>0
QUIT
IF $DATA(^RMPR(661,"B",RNI))
SET RIT(RNI,RXX)=""
+1 SET RB=""
FOR RF=0:0
SET RB=$ORDER(RD(RB))
if RB=""
QUIT
if RMPRY
SET AZL=3
SET RJ=$EXTRACT(RB,1,AZL)
FOR KK=0:0
SET RJ=$ORDER(^PRC(441,"C",RJ))
if $EXTRACT(RB,1,AZL)'=$EXTRACT(RJ,1,AZL)
QUIT
FOR RIN=0:0
SET RIN=$ORDER(^PRC(441,"C",RJ,RIN))
if RIN'>0
QUIT
IF $DATA(^RMPR(661,"B",RIN))
SET RIT(RIN,RJ)=""
+2 QUIT
