- 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 Feb 19, 2025@00:02:52 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