RMPFET3 ;DDC/KAW-EVALUATE ORDER STATUS [ 05/06/97  8:22 AM ]
 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**5**;JUN 16, 1995
 ;; input: RMPFX,RMPFTYP
 ;;output: RMPFST,RMPFERR
 Q:'$D(RMPFX)  Q:'$D(RMPFTYP)  S X=$P($G(^RMPF(791810.1,RMPFTYP,0)),U,3)
 S RMPFSTO=$P(^RMPF(791810,RMPFX,0),U,3) K RMPFST,RMPFERR
 I X="P" D
 .S IX=$G(^RMPF(791810,RMPFX,2)) Q:$P(IX,U,2)
 .I $P(IX,U,3) S RMPFERR("PATIENT NOT ELIGIBLE PER PSAS - PLEASE DELETE ORDER")="" Q
 .S RMPFERR("ELIGIBILITY HAS NOT BEEN DETERMINED BY PSAS")=""
 D ARRAY^RMPFDT2
 I '$D(RMPFO) D  G CK0:$D(RMPFST),END
 .I RMPFSTO,$D(^RMPF(791810.2,RMPFSTO,0)) S X=$P(^(0),U,5) I X'="E" K RMPFST Q
 .I RMPFSTO=6!(RMPFSTO=7)!(RMPFSTO=18) K RMPFST Q
 .S RMPFST=2
 S (X,A1,B1,C1)=0,(A,B,C)=1 F  S X=$O(RMPFO(X)) Q:'X  S Y=RMPFO(X) S:Y="" Y=1 I $D(^RMPF(791810.2,Y,0)) S S0=^(0) D
 .S Y1=$P(S0,U,5),Y2=$P(S0,U,9) S:Y1="C" A1=Y S:Y1="E" C1=Y
 .I Y1'="C" S A=0
 .I Y1'="P" S B=0
 .I Y2 S B1=$S(B1=0:Y,Y2<B1:Y,1:B1)
 I A S RMPFST=8 G EXIT
 I B S RMPFST=B1 G EXIT
 I A1&B1&'C1 S RMPFST=B1 G EXIT
EVAL S FY=0,SX="" K RMPFST F  S FY=$O(RMPFO(FY)) Q:'FY  D  Q:$D(RMPFST)
 .S ST=$P($G(^RMPF(791810,RMPFX,101,FY,0)),U,18)
 .Q:'ST  Q:'$D(^RMPF(791810.2,ST,0))  S SC=$P(^(0),U,5)
 .Q:SC'="E"  I ST=6!(ST=7)!(ST=18) S RMPFST=ST Q
 .I SX="" S SX=ST Q
 .I ST<SX S SX=ST
 I '$D(RMPFST) S RMPFST=SX
CK0 S CK=0
CK1 F I=1:1 S CK=$O(^RMPF(791810.1,RMPFTYP,100,CK)) Q:'CK  D
 .Q:'$D(^RMPF(791810.1,RMPFTYP,100,CK,0))  Q:'$P(^(0),U,3)  S S2=$P(^(0),U,2)
 .S ND=$$GET1^DID(791810,S2,"","GLOBAL SUBSCRIPT LOCATION")   S A=$P(ND,U,4)
 .S B=$P(ND,";",1),C=$P(ND,";",2) Q:B=""!(C="")
 .I $D(^RMPF(791810,RMPFX,B)),$P(^RMPF(791810,RMPFX,B),U,C)'="" Q
 .S E=$$GET1^DID(791810,S2,"","LABEL") S:E'="" RMPFERR(E)=""
CK2 S ST="" I $D(^RMPF(791810.1,RMPFTYP,2)) S ST=$P(^(2),U,1) I ST'="" D
 .S FY=0 F I=1:1 S FY=$O(^RMPF(791810,RMPFX,101,FY)) Q:'FY  D
 ..Q:'$D(^RMPF(791810,RMPFX,101,FY,0))
 ..F J=1:1 S D=$P(ST,";",J) Q:D=""  D  Q:D=9999
 ...I D?1"I ".E X D Q:'$T  S D=9999 Q
 ...S ND=$$GET1^DID(791810.0101,D,"","GLOBAL SUBSCRIPT LOCATION") S A=$P(ND,U,4),B=$P(A,";",1),C=$P(A,";",2) Q:B=""!(C="")
 ...I $D(^RMPF(791810,RMPFX,101,FY,B)),C=0,$O(^RMPF(791810,RMPFX,101,FY,B,0)) Q
 ...I $D(^RMPF(791810,RMPFX,101,FY,B)),C'=0,$P(^RMPF(791810,RMPFX,101,FY,B),U,C)'="" Q
 ...S E=$$GET1^DID(791810.0101,D,"","LABEL") S:E'="" RMPFERR(E)=""
 I ST[".01",'$O(^RMPF(791810,RMPFX,101,0)) S RMPFERR("NO ITEM SELECTED")=""
SPEC I $D(^RMPF(791810.1,RMPFTYP,2)) S SP=$P(^(2),U,2) I SP'="" D @(SP_U_"RMPFET4")
EXIT I $D(RMPFERR),RMPFTYP'=5 S RMPFST=1
 G END:RMPFST=RMPFSTO S %DT="T",X="NOW" D ^%DT
 S DIE="^RMPF(791810,",DA=RMPFX,DR=".03////"_RMPFST_";.06////"_Y D ^DIE
END K RMPFO,RMPFSTO,RMPFK,Y1,SO,FY,ST,S,X,J,S0,S2,SD,SP,SX,SE,A,B,C,I,CK
 K A1,B1,C1,IX,Y1,Y2,SC,%DT,D0,DR,DA,DQ,DI,DIC,DIE,D,ND,E Q