- 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 Feb 19, 2025@00:02:48 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
