source: FOIAVistA/trunk/r/REMOTE_ORDER_ENTRY_SYSTEM-RMPF-RMPJ/RMPFEA2.m

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

initial load of FOIAVistA 6/30/08 version
File size: 4.7 KB
Line 
1RMPFEA2 ;DDC/KAW-APPROVE ORDERS [ 06/20/97 10:39 AM ]
2 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**3**;MAY 30, 1995
3APPROV ;; input: RMPFX,RMPFHAT
4 ;;output: None
5 S X=$P(^RMPF(791810,RMPFX,0),U,3) G END:'X
6 S FX="PS" D
7 .I RMPFHAT="I"!(RMPFHAT="X") S FX=FX_"F" Q
8 .D ARRAY^RMPFDT2 S XX=0
9 .F S XX=$O(RMPFO(XX)) Q:'XX I $D(^RMPF(791810,RMPFX,101,XX,0)),$P(^(0),U,19)["A",$P(^(0),U,20) S FX=FX_"F" Q
10 G END:'$D(^RMPF(791810.2,X,0)) S ST=$P(^(0),U,2) G END:FX'[ST
11 I RMPFHAT="I" S X=$P(^RMPF(791810,RMPFX,0),U,3) D G END:$D(X),APP
12 .I $P($G(^RMPF(791810.2,X,0)),U,5)'="E"&($P(^(0),U,2)'="C") Q
13 .D ARRAY^RMPFDT2 S X=0
14 .F S X=$O(RMPFO(X)) Q:'X I $P($G(^RMPF(791810,RMPFX,101,X,0)),U,20) Q
15 .I X K X
16AP S X=$P(RMPFSYS,U,7) S:X="" X="S" G APP:X="N"
17 I RMPFMENU=10,X="A" G APP
18 I X="A",$D(^RMPF(791813,RMPFSTAN,101,DUZ,0)),$P(^(0),U,3) G APP
19 I '$D(^XUSEC("RMPF SUPERVISOR",DUZ)) Q
20APPROV1 S X=$P(^RMPF(791810,RMPFX,0),U,3) G END:'X
21 G END:'$D(^RMPF(791810.2,X,0)) S ST=$P(^(0),U,2) G END:"PSF"'[ST
22 D ARRAY^RMPFDT2 K ED
23 I X="S" D G END:'$D(ED),APP
24 .S O=0
25 .F S O=$O(RMPFO(O)) Q:'O I $P(^RMPF(791810,RMPFX,101,O,0),U,20) S ED="" Q
26 I RMPFHAT'="U" S Y=0 F S Y=$O(RMPFO(Y)) Q:'Y I $D(^RMPF(791810,RMPFX,101,Y,0)),$P(^(0),U,19)="C",$P(^(0),U,20) G APP
27 Q:"BPSF"'[ST
28APP W !!,"APPROVE this order? YES// " D READ Q:$D(RMPFOUT)
29APP1 I $D(RMPFQUT) W !!,"Enter <Y> to approve the order and place it in a batch or <N> to continue." G APP
30 S:Y="" Y="Y" S Y=$E(Y,1) I "YyNn"'[Y S RMPFQUT="" G APP1
31 G END:"Nn"[Y
32SET ;; input: RMPFX,RMPFHAT
33 ;;output: None
34 S FL=0 I RMPFHAT="Y"!(RMPFHAT="K") D BATCH G SETX
35 D ARRAY^RMPFDT2 S FY=0
36ST1 S FY=$O(RMPFO(FY)) G SETX:'FY
37 G ST1:'$D(^RMPF(791810,RMPFX,101,FY,0)) S S0=^(0)
38 S X=$P(S0,U,18),Y=$P(S0,U,20) G ST1:'Y
39 G ST1:X="" S X=$P($G(^RMPF(791810.2,X,0)),U,2)
40 I X="C",$P(^RMPF(791810,RMPFX,101,FY,0),U,20),$P(^(0),U,19)["A" G ST2
41 G ST1:"PSNAF"'[X
42 I X="A",Y G ST2
43 I X="S",'$P($G(^RMPF(791810,RMPFX,101,FY,90)),U,9),$P(^(0),U,19)'["A" G ST1
44 I X="S",$P(S0,U,19)["I" G ST1:$P(S0,U,2)="",ST1:$P(S0,U,5)="",ST1:$P(S0,U,8)=""
45ST2 S FL=1 D SET1 G ST1
46SETX I 'FL G SETE:RMPFHAT'="K"&(RMPFHAT'="Y")
47 S %DT="T",X="NOW" D ^%DT S DIE="^RMPF(791810,",DA=RMPFX
48 S DR=".03///APPROVED;.06////"_Y_";.1////"_DUZ_";.11////"_Y D ^DIE
49 S RMPFCAT=$P($G(^RMPF(791810,RMPFX,10)),U,5)
50 I RMPFCAT'="","PE"[RMPFCAT D EMER^RMPFEA3
51 D FORM:RMPFHAT="S"
52 I RMPFHAT="I" D ARRAY^RMPFDT2 S X=0 F S X=$O(RMPFO(X)) Q:'X I $D(^RMPF(791810,RMPFX,101,X,0)),$P(^(0),U,19)["I" D FORM Q
53SETE K FL,RMPFBT,RMPFCAT,X,Y,S0,%DT,D,D0,DA,DI,DIC,DIE,DQ,DR,FY,RMPFO Q
54SET1 ;;Set to approved and place in a batch when line item known
55 ;; input: FY,PT,RMPFX
56 ;;output: RMPFBT
57 S DIE="^RMPF(791810,"_RMPFX_",101,",DA(1)=RMPFX,DA=FY
58 S X="NOW",%DT="T" D ^%DT
59 S X=$S($P(^RMPF(791810,RMPFX,101,FY,0),U,15)'="C":"APPROVED",1:"CANCELED")
60 S DR=".18///"_X_";.17////"_Y_";.2////0" D ^DIE
61 K DIE,DI,DR,D0,D,%,%DT,DISYS,DQ,I,L
62BATCH ;;Find open batch
63 S RMPFBT=0,MN=$O(^RMPF(791810.5,"C",RMPFMENU,0))
64 F I=1:1 S RMPFBT=$O(^RMPF(791812,"C",1,RMPFBT)) Q:'RMPFBT S S1=$G(^RMPF(791812,RMPFBT,0)) I $P(S1,U,8)=RMPFSTAP S X=$P(S1,U,9) S:X="" X=0 I X=MN Q
65 G TRANS:RMPFBT S X="NOW",%DT="T" D ^%DT S X=Y
66 F I=1:1 Q:'$D(^RMPF(791812,"B",X)) S X=X+.00001
67 S DIC="^RMPF(791812,",DIC(0)="L",DLAYGO=791812
68 S DIC("DR")=".02////1;.08////"_RMPFSTAP_";.09////"_$O(^RMPF(791810.5,"C",RMPFMENU,0))
69 K DD,DO D FILE^DICN K DIC
70 I Y=-1 W !!,$C(7),"*** UNABLE TO ADD A NEW BATCH - CONTACT IRMS ***" G END
71 S RMPFBT=+Y I $P(RMPFSYS,U,3)="A" D ^RMPFEA3
72TRANS ;;Add order to a batch
73 S:'$D(^RMPF(791812,RMPFBT,101,0)) ^RMPF(791812,RMPFBT,101,0)="^791812.0101PA^^" L ^RMPF(791812,RMPFBT)
74 G BATCHE:'$D(^RMPF(791810,RMPFX,0))
75 S PT=$O(^RMPF(791812,RMPFBT,101,"B",RMPFX,0))
76 I PT,$D(^RMPF(791812,RMPFBT,101,PT,0)),$P(^(0),U,2) D G BATCHE
77 .S $P(^(0),U,2,4)="",$P(^RMPF(791810,RMPFX,10),U,2)=""
78 .S X=$P(^RMPF(791812,RMPFBT,0),U,4),X=X+1,$P(^(0),U,4)=X
79 I PT,$D(^RMPF(791812,RMPFBT,101,PT,0)) G BATCHE
80 S X=RMPFX,DIC="^RMPF(791812,"_RMPFBT_",101,",DA(1)=RMPFBT,DIC(0)="L"
81 S DLAYGO=791812 K DD,DO D ^DICN
82 I Y=-1 W !!,$C(7),"*** NOT ADDED - CONTACT IRMS ***" G BATCHE
83COUNT S X=$P(^RMPF(791812,RMPFBT,0),U,4),X=X+1,$P(^(0),U,4)=X
84 W !!?20,"*** ADDED TO TRANSMISSION BATCH *** " H 1
85 S DIE="^RMPF(791810,",DA=RMPFX,DR=".12////"_RMPFBT D ^DIE
86BATCHE L K DIC,DA,DLAYGO,PT,X,Y,S1,I,%,DIE,D0,DQ,D,DI,DR,%DT,%X,%Y Q
87END K ED,MN,X,FX,RMPFBT,FY,O,S,Y,XX Q
88 K RMPFLIS,RMPFLISD,RMPFSD,RMPFY,S0,S3 Q
89FORM W !!,"Print Form 10-2477a? NO// " D READ Q:$D(RMPFOUT)
90FORM1 I $D(RMPFQUT) W !!,"Enter a <Y> to print a 2477a, <N> or <RETURN> to exit." G FORM
91 S:Y="" Y="N" S Y=$E(Y,1) I "YyNn"'[Y S RMPFQUT="" G FORM1
92 I "Yy"[Y S RMPFRTN="^RMPFQP3" D QUE^RMPFQP
93 Q
94READ K RMPFOUT,RMPFQUT
95 R Y:DTIME I '$T W $C(7) R Y:5 G READ:Y="." S:'$T Y=U
96 I Y?1"^".E S (RMPFOUT,Y)="" Q
97 S:Y?1"?".E (RMPFQUT,Y)=""
98 Q
Note: See TracBrowser for help on using the repository browser.