- 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 Feb 18, 2025@23:59:04 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