| 1 | RMPFET3 ;DDC/KAW-EVALUATE ORDER STATUS [ 05/06/97 8:22 AM ]
|
|---|
| 2 | ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**5**;JUN 16, 1995
|
|---|
| 3 | ;; input: RMPFX,RMPFTYP
|
|---|
| 4 | ;;output: RMPFST,RMPFERR
|
|---|
| 5 | Q:'$D(RMPFX) Q:'$D(RMPFTYP) S X=$P($G(^RMPF(791810.1,RMPFTYP,0)),U,3)
|
|---|
| 6 | S RMPFSTO=$P(^RMPF(791810,RMPFX,0),U,3) K RMPFST,RMPFERR
|
|---|
| 7 | I X="P" D
|
|---|
| 8 | .S IX=$G(^RMPF(791810,RMPFX,2)) Q:$P(IX,U,2)
|
|---|
| 9 | .I $P(IX,U,3) S RMPFERR("PATIENT NOT ELIGIBLE PER PSAS - PLEASE DELETE ORDER")="" Q
|
|---|
| 10 | .S RMPFERR("ELIGIBILITY HAS NOT BEEN DETERMINED BY PSAS")=""
|
|---|
| 11 | D ARRAY^RMPFDT2
|
|---|
| 12 | I '$D(RMPFO) D G CK0:$D(RMPFST),END
|
|---|
| 13 | .I RMPFSTO,$D(^RMPF(791810.2,RMPFSTO,0)) S X=$P(^(0),U,5) I X'="E" K RMPFST Q
|
|---|
| 14 | .I RMPFSTO=6!(RMPFSTO=7)!(RMPFSTO=18) K RMPFST Q
|
|---|
| 15 | .S RMPFST=2
|
|---|
| 16 | 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
|
|---|
| 17 | .S Y1=$P(S0,U,5),Y2=$P(S0,U,9) S:Y1="C" A1=Y S:Y1="E" C1=Y
|
|---|
| 18 | .I Y1'="C" S A=0
|
|---|
| 19 | .I Y1'="P" S B=0
|
|---|
| 20 | .I Y2 S B1=$S(B1=0:Y,Y2<B1:Y,1:B1)
|
|---|
| 21 | I A S RMPFST=8 G EXIT
|
|---|
| 22 | I B S RMPFST=B1 G EXIT
|
|---|
| 23 | I A1&B1&'C1 S RMPFST=B1 G EXIT
|
|---|
| 24 | EVAL S FY=0,SX="" K RMPFST F S FY=$O(RMPFO(FY)) Q:'FY D Q:$D(RMPFST)
|
|---|
| 25 | .S ST=$P($G(^RMPF(791810,RMPFX,101,FY,0)),U,18)
|
|---|
| 26 | .Q:'ST Q:'$D(^RMPF(791810.2,ST,0)) S SC=$P(^(0),U,5)
|
|---|
| 27 | .Q:SC'="E" I ST=6!(ST=7)!(ST=18) S RMPFST=ST Q
|
|---|
| 28 | .I SX="" S SX=ST Q
|
|---|
| 29 | .I ST<SX S SX=ST
|
|---|
| 30 | I '$D(RMPFST) S RMPFST=SX
|
|---|
| 31 | CK0 S CK=0
|
|---|
| 32 | CK1 F I=1:1 S CK=$O(^RMPF(791810.1,RMPFTYP,100,CK)) Q:'CK D
|
|---|
| 33 | .Q:'$D(^RMPF(791810.1,RMPFTYP,100,CK,0)) Q:'$P(^(0),U,3) S S2=$P(^(0),U,2)
|
|---|
| 34 | .S ND=$$GET1^DID(791810,S2,"","GLOBAL SUBSCRIPT LOCATION") S A=$P(ND,U,4)
|
|---|
| 35 | .S B=$P(ND,";",1),C=$P(ND,";",2) Q:B=""!(C="")
|
|---|
| 36 | .I $D(^RMPF(791810,RMPFX,B)),$P(^RMPF(791810,RMPFX,B),U,C)'="" Q
|
|---|
| 37 | .S E=$$GET1^DID(791810,S2,"","LABEL") S:E'="" RMPFERR(E)=""
|
|---|
| 38 | CK2 S ST="" I $D(^RMPF(791810.1,RMPFTYP,2)) S ST=$P(^(2),U,1) I ST'="" D
|
|---|
| 39 | .S FY=0 F I=1:1 S FY=$O(^RMPF(791810,RMPFX,101,FY)) Q:'FY D
|
|---|
| 40 | ..Q:'$D(^RMPF(791810,RMPFX,101,FY,0))
|
|---|
| 41 | ..F J=1:1 S D=$P(ST,";",J) Q:D="" D Q:D=9999
|
|---|
| 42 | ...I D?1"I ".E X D Q:'$T S D=9999 Q
|
|---|
| 43 | ...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="")
|
|---|
| 44 | ...I $D(^RMPF(791810,RMPFX,101,FY,B)),C=0,$O(^RMPF(791810,RMPFX,101,FY,B,0)) Q
|
|---|
| 45 | ...I $D(^RMPF(791810,RMPFX,101,FY,B)),C'=0,$P(^RMPF(791810,RMPFX,101,FY,B),U,C)'="" Q
|
|---|
| 46 | ...S E=$$GET1^DID(791810.0101,D,"","LABEL") S:E'="" RMPFERR(E)=""
|
|---|
| 47 | I ST[".01",'$O(^RMPF(791810,RMPFX,101,0)) S RMPFERR("NO ITEM SELECTED")=""
|
|---|
| 48 | SPEC I $D(^RMPF(791810.1,RMPFTYP,2)) S SP=$P(^(2),U,2) I SP'="" D @(SP_U_"RMPFET4")
|
|---|
| 49 | EXIT I $D(RMPFERR),RMPFTYP'=5 S RMPFST=1
|
|---|
| 50 | G END:RMPFST=RMPFSTO S %DT="T",X="NOW" D ^%DT
|
|---|
| 51 | S DIE="^RMPF(791810,",DA=RMPFX,DR=".03////"_RMPFST_";.06////"_Y D ^DIE
|
|---|
| 52 | END K RMPFO,RMPFSTO,RMPFK,Y1,SO,FY,ST,S,X,J,S0,S2,SD,SP,SX,SE,A,B,C,I,CK
|
|---|
| 53 | K A1,B1,C1,IX,Y1,Y2,SC,%DT,D0,DR,DA,DQ,DI,DIC,DIE,D,ND,E Q
|
|---|
