source: FOIAVistA/trunk/r/REMOTE_ORDER_ENTRY_SYSTEM-RMPF-RMPJ/RMPFET3.m@ 1757

Last change on this file since 1757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 2.7 KB
Line 
1RMPFET3 ;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
24EVAL 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
31CK0 S CK=0
32CK1 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)=""
38CK2 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")=""
48SPEC I $D(^RMPF(791810.1,RMPFTYP,2)) S SP=$P(^(2),U,2) I SP'="" D @(SP_U_"RMPFET4")
49EXIT 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
52END 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
Note: See TracBrowser for help on using the repository browser.