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

RMPFEA2 ;DDC/KAW-APPROVE ORDERS [ 06/20/97  10:39 AM ]
 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**3**;MAY 30, 1995
APPROV ;; input: RMPFX,RMPFHAT
 ;;output: None
 S X=$P(^RMPF(791810,RMPFX,0),U,3) G END:'X
 S FX="PS" D
 .I RMPFHAT="I"!(RMPFHAT="X") S FX=FX_"F" Q
 .D ARRAY^RMPFDT2 S XX=0
 .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
 G END:'$D(^RMPF(791810.2,X,0)) S ST=$P(^(0),U,2) G END:FX'[ST
 I RMPFHAT="I" S X=$P(^RMPF(791810,RMPFX,0),U,3) D  G END:$D(X),APP
 .I $P($G(^RMPF(791810.2,X,0)),U,5)'="E"&($P(^(0),U,2)'="C") Q
 .D ARRAY^RMPFDT2 S X=0
 .F  S X=$O(RMPFO(X)) Q:'X  I $P($G(^RMPF(791810,RMPFX,101,X,0)),U,20) Q
 .I X K X
AP S X=$P(RMPFSYS,U,7) S:X="" X="S" G APP:X="N"
 I RMPFMENU=10,X="A" G APP
 I X="A",$D(^RMPF(791813,RMPFSTAN,101,DUZ,0)),$P(^(0),U,3) G APP
 I '$D(^XUSEC("RMPF SUPERVISOR",DUZ)) Q
APPROV1 S X=$P(^RMPF(791810,RMPFX,0),U,3) G END:'X
 G END:'$D(^RMPF(791810.2,X,0)) S ST=$P(^(0),U,2) G END:"PSF"'[ST
 D ARRAY^RMPFDT2 K ED
 I X="S" D  G END:'$D(ED),APP
 .S O=0
 .F  S O=$O(RMPFO(O)) Q:'O  I $P(^RMPF(791810,RMPFX,101,O,0),U,20) S ED="" Q
 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
 Q:"BPSF"'[ST
APP W !!,"APPROVE this order? YES// " D READ Q:$D(RMPFOUT)
APP1 I $D(RMPFQUT) W !!,"Enter <Y> to approve the order and place it in a batch or <N> to continue." G APP
 S:Y="" Y="Y" S Y=$E(Y,1) I "YyNn"'[Y S RMPFQUT="" G APP1
 G END:"Nn"[Y
SET ;; input: RMPFX,RMPFHAT
 ;;output: None
 S FL=0 I RMPFHAT="Y"!(RMPFHAT="K") D BATCH G SETX
 D ARRAY^RMPFDT2 S FY=0
ST1 S FY=$O(RMPFO(FY)) G SETX:'FY
 G ST1:'$D(^RMPF(791810,RMPFX,101,FY,0)) S S0=^(0)
 S X=$P(S0,U,18),Y=$P(S0,U,20) G ST1:'Y
 G ST1:X="" S X=$P($G(^RMPF(791810.2,X,0)),U,2)
 I X="C",$P(^RMPF(791810,RMPFX,101,FY,0),U,20),$P(^(0),U,19)["A" G ST2
 G ST1:"PSNAF"'[X
 I X="A",Y G ST2
 I X="S",'$P($G(^RMPF(791810,RMPFX,101,FY,90)),U,9),$P(^(0),U,19)'["A" G ST1
 I X="S",$P(S0,U,19)["I" G ST1:$P(S0,U,2)="",ST1:$P(S0,U,5)="",ST1:$P(S0,U,8)=""
ST2 S FL=1 D SET1 G ST1
SETX I 'FL G SETE:RMPFHAT'="K"&(RMPFHAT'="Y")
 S %DT="T",X="NOW" D ^%DT S DIE="^RMPF(791810,",DA=RMPFX
 S DR=".03///APPROVED;.06////"_Y_";.1////"_DUZ_";.11////"_Y D ^DIE
 S RMPFCAT=$P($G(^RMPF(791810,RMPFX,10)),U,5)
 I RMPFCAT'="","PE"[RMPFCAT D EMER^RMPFEA3
 D FORM:RMPFHAT="S"
 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
SETE K FL,RMPFBT,RMPFCAT,X,Y,S0,%DT,D,D0,DA,DI,DIC,DIE,DQ,DR,FY,RMPFO Q
SET1 ;;Set to approved and place in a batch when line item known
 ;; input: FY,PT,RMPFX
 ;;output: RMPFBT
 S DIE="^RMPF(791810,"_RMPFX_",101,",DA(1)=RMPFX,DA=FY
 S X="NOW",%DT="T" D ^%DT
 S X=$S($P(^RMPF(791810,RMPFX,101,FY,0),U,15)'="C":"APPROVED",1:"CANCELED")
 S DR=".18///"_X_";.17////"_Y_";.2////0" D ^DIE
 K DIE,DI,DR,D0,D,%,%DT,DISYS,DQ,I,L
BATCH ;;Find open batch
 S RMPFBT=0,MN=$O(^RMPF(791810.5,"C",RMPFMENU,0))
 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
 G TRANS:RMPFBT S X="NOW",%DT="T" D ^%DT S X=Y
 F I=1:1 Q:'$D(^RMPF(791812,"B",X))  S X=X+.00001
 S DIC="^RMPF(791812,",DIC(0)="L",DLAYGO=791812
 S DIC("DR")=".02////1;.08////"_RMPFSTAP_";.09////"_$O(^RMPF(791810.5,"C",RMPFMENU,0))
 K DD,DO D FILE^DICN K DIC
 I Y=-1 W !!,$C(7),"*** UNABLE TO ADD A NEW BATCH - CONTACT IRMS ***" G END
 S RMPFBT=+Y I $P(RMPFSYS,U,3)="A" D ^RMPFEA3
TRANS ;;Add order to a batch
 S:'$D(^RMPF(791812,RMPFBT,101,0)) ^RMPF(791812,RMPFBT,101,0)="^791812.0101PA^^" L ^RMPF(791812,RMPFBT)
 G BATCHE:'$D(^RMPF(791810,RMPFX,0))
 S PT=$O(^RMPF(791812,RMPFBT,101,"B",RMPFX,0))
 I PT,$D(^RMPF(791812,RMPFBT,101,PT,0)),$P(^(0),U,2) D  G BATCHE
 .S $P(^(0),U,2,4)="",$P(^RMPF(791810,RMPFX,10),U,2)=""
 .S X=$P(^RMPF(791812,RMPFBT,0),U,4),X=X+1,$P(^(0),U,4)=X
 I PT,$D(^RMPF(791812,RMPFBT,101,PT,0)) G BATCHE
 S X=RMPFX,DIC="^RMPF(791812,"_RMPFBT_",101,",DA(1)=RMPFBT,DIC(0)="L"
 S DLAYGO=791812 K DD,DO D ^DICN
 I Y=-1 W !!,$C(7),"*** NOT ADDED - CONTACT IRMS ***" G BATCHE
COUNT S X=$P(^RMPF(791812,RMPFBT,0),U,4),X=X+1,$P(^(0),U,4)=X
 W !!?20,"*** ADDED TO TRANSMISSION BATCH *** " H 1
 S DIE="^RMPF(791810,",DA=RMPFX,DR=".12////"_RMPFBT D ^DIE
BATCHE L  K DIC,DA,DLAYGO,PT,X,Y,S1,I,%,DIE,D0,DQ,D,DI,DR,%DT,%X,%Y Q
END K ED,MN,X,FX,RMPFBT,FY,O,S,Y,XX Q
 K RMPFLIS,RMPFLISD,RMPFSD,RMPFY,S0,S3 Q
FORM W !!,"Print Form 10-2477a? NO// " D READ Q:$D(RMPFOUT)
FORM1 I $D(RMPFQUT) W !!,"Enter a <Y> to print a 2477a, <N> or <RETURN> to exit." G FORM
 S:Y="" Y="N" S Y=$E(Y,1) I "YyNn"'[Y S RMPFQUT="" G FORM1
 I "Yy"[Y S RMPFRTN="^RMPFQP3" D QUE^RMPFQP
 Q
READ K RMPFOUT,RMPFQUT
 R Y:DTIME I '$T W $C(7) R Y:5 G READ:Y="." S:'$T Y=U
 I Y?1"^".E S (RMPFOUT,Y)="" Q
 S:Y?1"?".E (RMPFQUT,Y)=""
 Q