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