RMPFET61 ;DDC/KAW-EVALUATE LINE ITEM STATUS [ 06/16/95 3:06 PM ]
;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
;; input: RMPFX,RMPFY,RMPFTYP,RMPFSTR0,RMPFSTR2,RMPFSTR3
;;output: RMPFERR
Q:'$D(^RMPF(791810,RMPFX,101,RMPFY,0))
K RMPFEDIT,RMPFERR S RMPFSTP=""
S X=$P(^RMPF(791810,RMPFX,101,RMPFY,0),U,18)
I X,$D(^RMPF(791810.2,X,0)) S RMPFSTP=$P(^(0),U,2)
F I=4,8,9,10:1:16 I X=I G END
S:RMPFSTP="" RMPFSTP="I" I RMPFSTP="I" S RMPFEDIT=""
F I=0,2,3 S X=$G(^RMPF(791810,RMPFX,101,RMPFY,I)) I X'=@("RMPFSTR"_I) S RMPFEDIT="" Q
G END:'$D(RMPFEDIT)
CK2 S ST="" I $D(^RMPF(791810.1,RMPFTYP,2)) S ST=$P(^(2),U,1) I ST'="" D
.Q:'$D(^RMPF(791810,RMPFX,101,RMPFY,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,RMPFY,B)),C=0,$O(^RMPF(791810,RMPFX,101,RMPFY,B,0)) Q
..I $D(^RMPF(791810,RMPFX,101,RMPFY,B)),C'=0,$P(^RMPF(791810,RMPFX,101,RMPFY,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")=""
S DIE="^RMPF(791810,"_RMPFX_",101,",DA(1)=RMPFX,DA=RMPFY
I RMPFTYP'=5 S S=$S('$D(RMPFERR):"PENDING",1:"INCOMPLETE")
E S S=$S('$D(RMPFERR):"ISSUE DATE PENDING",1:"ERROR")
S %DT="T",X="NOW" D ^%DT
S DR=".17////"_Y_";.18///"_S_";.2////1"
I $D(RMPFLA) S DR=DR_";.19////"_RMPFLA
D ^DIE
END K RMPFSTP,RMPFSTR0,RMPFSTR2,RMPFSTR3,I,J,X,ST,RMPFEDIT,%DT,A,B,C,D,S
K D0,DA,DI,DIC,DIE,DQ,DR,RMPFLA Q
PRIOR ;;Record data strings prior to editing
;; input: RMPFX,RMPFY
;;output: RMPFSTR0,RMPFSTR2,RMPFSTR3
F I=0,2,3 S @("RMPFSTR"_I)=$G(^RMPF(791810,RMPFX,101,RMPFY,I))
K I Q
CLEAR ;;Clear errors and disapprovals by line item
;; input: RMPFX,RMPFY,RMPFSTO
;;output: None
W !!,"The status of this line item order is "
W $P(^RMPF(791810.2,$P(^RMPF(791810,RMPFX,101,RMPFY,0),U,18),0),U,1)
CL1 W !!,"Do you wish to clear this status and edit the order? NO// "
D READ Q:$D(RMPFOUT)
CL11 I $D(RMPFQUT) W !!,"Enter a <Y> to clear the status and edit the order",!?5,"an <N> to leave the status as it is" G CL1
S YX=Y S:YX="" YX="N" S YX=$E(YX,1) I "NnYy"'[YX S RMPFQUT="" G CL11
I "Nn"[YX K RMPFSTO G CLEARE
S %DT="T",X="NOW" D ^%DT
S ST=$S(RMPFSTO="S":"ISSUE DATE PENDING",1:"INCOMPLETE")
S DIE="^RMPF(791810,"_RMPFX_",101,",DA(1)=RMPFX,DA=RMPFY
S DR=".17////"_Y_";.18///"_ST_";.19////O;.2////1" D ^DIE
CLEARE K X,Y,YX,%DT,D0,DA,DI,DIC,DIE,DQ,DR,ST 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[HRMPFET61 2741 printed Dec 13, 2024@02:36:21 Page 2
RMPFET61 ;DDC/KAW-EVALUATE LINE ITEM STATUS [ 06/16/95 3:06 PM ]
+1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
+2 ;; input: RMPFX,RMPFY,RMPFTYP,RMPFSTR0,RMPFSTR2,RMPFSTR3
+3 ;;output: RMPFERR
+4 if '$DATA(^RMPF(791810,RMPFX,101,RMPFY,0))
QUIT
+5 KILL RMPFEDIT,RMPFERR
SET RMPFSTP=""
+6 SET X=$PIECE(^RMPF(791810,RMPFX,101,RMPFY,0),U,18)
+7 IF X
IF $DATA(^RMPF(791810.2,X,0))
SET RMPFSTP=$PIECE(^(0),U,2)
+8 FOR I=4,8,9,10:1:16
IF X=I
GOTO END
+9 if RMPFSTP=""
SET RMPFSTP="I"
IF RMPFSTP="I"
SET RMPFEDIT=""
+10 FOR I=0,2,3
SET X=$GET(^RMPF(791810,RMPFX,101,RMPFY,I))
IF X'=@("RMPFSTR"_I)
SET RMPFEDIT=""
QUIT
+11 if '$DATA(RMPFEDIT)
GOTO END
CK2 SET ST=""
IF $DATA(^RMPF(791810.1,RMPFTYP,2))
SET ST=$PIECE(^(2),U,1)
IF ST'=""
Begin DoDot:1
+1 if '$DATA(^RMPF(791810,RMPFX,101,RMPFY,0))
QUIT
+2 FOR J=1:1
SET D=$PIECE(ST,";",J)
if D=""
QUIT
Begin DoDot:2
+3 IF D?1"I ".E
XECUTE D
if '$TEST
QUIT
SET D=9999
QUIT
+4 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
+5 IF $DATA(^RMPF(791810,RMPFX,101,RMPFY,B))
IF C=0
IF $ORDER(^RMPF(791810,RMPFX,101,RMPFY,B,0))
QUIT
+6 IF $DATA(^RMPF(791810,RMPFX,101,RMPFY,B))
IF C'=0
IF $PIECE(^RMPF(791810,RMPFX,101,RMPFY,B),U,C)'=""
QUIT
+7 SET E=$$GET1^DID(791810.0101,D,"","LABEL")
if E'=""
SET RMPFERR(E)=""
End DoDot:2
if D=9999
QUIT
End DoDot:1
+8 IF ST[".01"
IF '$ORDER(^RMPF(791810,RMPFX,101,0))
SET RMPFERR("NO ITEM SELECTED")=""
+9 SET DIE="^RMPF(791810,"_RMPFX_",101,"
SET DA(1)=RMPFX
SET DA=RMPFY
+10 IF RMPFTYP'=5
SET S=$SELECT('$DATA(RMPFERR):"PENDING",1:"INCOMPLETE")
+11 IF '$TEST
SET S=$SELECT('$DATA(RMPFERR):"ISSUE DATE PENDING",1:"ERROR")
+12 SET %DT="T"
SET X="NOW"
DO ^%DT
+13 SET DR=".17////"_Y_";.18///"_S_";.2////1"
+14 IF $DATA(RMPFLA)
SET DR=DR_";.19////"_RMPFLA
+15 DO ^DIE
END KILL RMPFSTP,RMPFSTR0,RMPFSTR2,RMPFSTR3,I,J,X,ST,RMPFEDIT,%DT,A,B,C,D,S
+1 KILL D0,DA,DI,DIC,DIE,DQ,DR,RMPFLA
QUIT
PRIOR ;;Record data strings prior to editing
+1 ;; input: RMPFX,RMPFY
+2 ;;output: RMPFSTR0,RMPFSTR2,RMPFSTR3
+3 FOR I=0,2,3
SET @("RMPFSTR"_I)=$GET(^RMPF(791810,RMPFX,101,RMPFY,I))
+4 KILL I
QUIT
CLEAR ;;Clear errors and disapprovals by line item
+1 ;; input: RMPFX,RMPFY,RMPFSTO
+2 ;;output: None
+3 WRITE !!,"The status of this line item order is "
+4 WRITE $PIECE(^RMPF(791810.2,$PIECE(^RMPF(791810,RMPFX,101,RMPFY,0),U,18),0),U,1)
CL1 WRITE !!,"Do you wish to clear this status and edit the order? NO// "
+1 DO READ
if $DATA(RMPFOUT)
QUIT
CL11 IF $DATA(RMPFQUT)
WRITE !!,"Enter a <Y> to clear the status and edit the order",!?5,"an <N> to leave the status as it is"
GOTO CL1
+1 SET YX=Y
if YX=""
SET YX="N"
SET YX=$EXTRACT(YX,1)
IF "NnYy"'[YX
SET RMPFQUT=""
GOTO CL11
+2 IF "Nn"[YX
KILL RMPFSTO
GOTO CLEARE
+3 SET %DT="T"
SET X="NOW"
DO ^%DT
+4 SET ST=$SELECT(RMPFSTO="S":"ISSUE DATE PENDING",1:"INCOMPLETE")
+5 SET DIE="^RMPF(791810,"_RMPFX_",101,"
SET DA(1)=RMPFX
SET DA=RMPFY
+6 SET DR=".17////"_Y_";.18///"_ST_";.19////O;.2////1"
DO ^DIE
CLEARE KILL X,Y,YX,%DT,D0,DA,DI,DIC,DIE,DQ,DR,ST
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
