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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFET3 2839 printed Nov 22, 2024@17:46:17 Page 2
RMPFET3 ;DDC/KAW-EVALUATE ORDER STATUS [ 05/06/97 8:22 AM ]
+1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**5**;JUN 16, 1995
+2 ;; input: RMPFX,RMPFTYP
+3 ;;output: RMPFST,RMPFERR
+4 if '$DATA(RMPFX)
QUIT
if '$DATA(RMPFTYP)
QUIT
SET X=$PIECE($GET(^RMPF(791810.1,RMPFTYP,0)),U,3)
+5 SET RMPFSTO=$PIECE(^RMPF(791810,RMPFX,0),U,3)
KILL RMPFST,RMPFERR
+6 IF X="P"
Begin DoDot:1
+7 SET IX=$GET(^RMPF(791810,RMPFX,2))
if $PIECE(IX,U,2)
QUIT
+8 IF $PIECE(IX,U,3)
SET RMPFERR("PATIENT NOT ELIGIBLE PER PSAS - PLEASE DELETE ORDER")=""
QUIT
+9 SET RMPFERR("ELIGIBILITY HAS NOT BEEN DETERMINED BY PSAS")=""
End DoDot:1
+10 DO ARRAY^RMPFDT2
+11 IF '$DATA(RMPFO)
Begin DoDot:1
+12 IF RMPFSTO
IF $DATA(^RMPF(791810.2,RMPFSTO,0))
SET X=$PIECE(^(0),U,5)
IF X'="E"
KILL RMPFST
QUIT
+13 IF RMPFSTO=6!(RMPFSTO=7)!(RMPFSTO=18)
KILL RMPFST
QUIT
+14 SET RMPFST=2
End DoDot:1
if $DATA(RMPFST)
GOTO CK0
GOTO END
+15 SET (X,A1,B1,C1)=0
SET (A,B,C)=1
FOR
SET X=$ORDER(RMPFO(X))
if 'X
QUIT
SET Y=RMPFO(X)
if Y=""
SET Y=1
IF $DATA(^RMPF(791810.2,Y,0))
SET S0=^(0)
Begin DoDot:1
+16 SET Y1=$PIECE(S0,U,5)
SET Y2=$PIECE(S0,U,9)
if Y1="C"
SET A1=Y
if Y1="E"
SET C1=Y
+17 IF Y1'="C"
SET A=0
+18 IF Y1'="P"
SET B=0
+19 IF Y2
SET B1=$SELECT(B1=0:Y,Y2<B1:Y,1:B1)
End DoDot:1
+20 IF A
SET RMPFST=8
GOTO EXIT
+21 IF B
SET RMPFST=B1
GOTO EXIT
+22 IF A1&B1&'C1
SET RMPFST=B1
GOTO EXIT
EVAL SET FY=0
SET SX=""
KILL RMPFST
FOR
SET FY=$ORDER(RMPFO(FY))
if 'FY
QUIT
Begin DoDot:1
+1 SET ST=$PIECE($GET(^RMPF(791810,RMPFX,101,FY,0)),U,18)
+2 if 'ST
QUIT
if '$DATA(^RMPF(791810.2,ST,0))
QUIT
SET SC=$PIECE(^(0),U,5)
+3 if SC'="E"
QUIT
IF ST=6!(ST=7)!(ST=18)
SET RMPFST=ST
QUIT
+4 IF SX=""
SET SX=ST
QUIT
+5 IF ST<SX
SET SX=ST
End DoDot:1
if $DATA(RMPFST)
QUIT
+6 IF '$DATA(RMPFST)
SET RMPFST=SX
CK0 SET CK=0
CK1 FOR I=1:1
SET CK=$ORDER(^RMPF(791810.1,RMPFTYP,100,CK))
if 'CK
QUIT
Begin DoDot:1
+1 if '$DATA(^RMPF(791810.1,RMPFTYP,100,CK,0))
QUIT
if '$PIECE(^(0),U,3)
QUIT
SET S2=$PIECE(^(0),U,2)
+2 SET ND=$$GET1^DID(791810,S2,"","GLOBAL SUBSCRIPT LOCATION")
SET A=$PIECE(ND,U,4)
+3 SET B=$PIECE(ND,";",1)
SET C=$PIECE(ND,";",2)
if B=""!(C="")
QUIT
+4 IF $DATA(^RMPF(791810,RMPFX,B))
IF $PIECE(^RMPF(791810,RMPFX,B),U,C)'=""
QUIT
+5 SET E=$$GET1^DID(791810,S2,"","LABEL")
if E'=""
SET RMPFERR(E)=""
End DoDot:1
CK2 SET ST=""
IF $DATA(^RMPF(791810.1,RMPFTYP,2))
SET ST=$PIECE(^(2),U,1)
IF ST'=""
Begin DoDot:1
+1 SET FY=0
FOR I=1:1
SET FY=$ORDER(^RMPF(791810,RMPFX,101,FY))
if 'FY
QUIT
Begin DoDot:2
+2 if '$DATA(^RMPF(791810,RMPFX,101,FY,0))
QUIT
+3 FOR J=1:1
SET D=$PIECE(ST,";",J)
if D=""
QUIT
Begin DoDot:3
+4 IF D?1"I ".E
XECUTE D
if '$TEST
QUIT
SET D=9999
QUIT
+5 SET ND=$$GET1^DID(791810.0101,D,"","GLOBAL SUBSCRIPT LOCATION")
SET A=$PIECE(ND,U,4)
SET B=$PIECE(A,";",1)
SET C=$PIECE(A,";",2)
if B=""!(C="")
QUIT
+6 IF $DATA(^RMPF(791810,RMPFX,101,FY,B))
IF C=0
IF $ORDER(^RMPF(791810,RMPFX,101,FY,B,0))
QUIT
+7 IF $DATA(^RMPF(791810,RMPFX,101,FY,B))
IF C'=0
IF $PIECE(^RMPF(791810,RMPFX,101,FY,B),U,C)'=""
QUIT
+8 SET E=$$GET1^DID(791810.0101,D,"","LABEL")
if E'=""
SET RMPFERR(E)=""
End DoDot:3
if D=9999
QUIT
End DoDot:2
End DoDot:1
+9 IF ST[".01"
IF '$ORDER(^RMPF(791810,RMPFX,101,0))
SET RMPFERR("NO ITEM SELECTED")=""
SPEC IF $DATA(^RMPF(791810.1,RMPFTYP,2))
SET SP=$PIECE(^(2),U,2)
IF SP'=""
DO @(SP_U_"RMPFET4")
EXIT IF $DATA(RMPFERR)
IF RMPFTYP'=5
SET RMPFST=1
+1 if RMPFST=RMPFSTO
GOTO END
SET %DT="T"
SET X="NOW"
DO ^%DT
+2 SET DIE="^RMPF(791810,"
SET DA=RMPFX
SET DR=".03////"_RMPFST_";.06////"_Y
DO ^DIE
END KILL RMPFO,RMPFSTO,RMPFK,Y1,SO,FY,ST,S,X,J,S0,S2,SD,SP,SX,SE,A,B,C,I,CK
+1 KILL A1,B1,C1,IX,Y1,Y2,SC,%DT,D0,DR,DA,DQ,DI,DIC,DIE,D,ND,E
QUIT
