54 lines
2.7 KiB
Mathematica
54 lines
2.7 KiB
Mathematica
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
|