PRCH1A3 ;WISC/PLT-PRCH1A continued ;9/8/98 11:10
V ;;5.1;IFCAP;**184**;Oct 20, 2000;Build 8
;Per VHA Directive 2004-038, this routine should not be modified.
;
;PRC*5.1*184 If Final Charge edited from 'Y' to 'N' add logic to
; flip the attached 2237s from Running Balance Status
; 'O' back to 'A' to insure they are carried forward
; to next fiscal quarter.
;
QUIT ;invalid entry
;
RC ;entry point - prch1d
;if the order is Simplified or Detailed but receiving is not required,
;confirm receipt with the user; otherwise check file #442,
;node 11 before asking the user any questions.
;
N PRCFOLD
S PRCE=^PRC(442,PRCRI(442),0),PRCCP=$P($G(^(23)),"^",16),PRCR=$P($G(^(23)),"^",15)
I PRCR="N",$P($G(^PRC(442,PRCRI(442),23)),"^",11)="S" D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),43) I $G(X)=-1 D EXIT QUIT
I PRCR="N",$P($G(^PRC(442,PRCRI(442),23)),"^",11)="P" D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),43) I $G(X)=-1 D EXIT QUIT
;
I PRCR="Y",$P($G(^PRC(442,PRCRI(442),23)),"^",11)="P" D I $G(X)=-1 D EXIT QUIT
. D CHKREC I $P($G(^PRCH(440.6,PRCRI(440.6),1)),"^",3)="Y" Q
. D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"43////N") I $G(X)=-1 D EXIT QUIT
;
;See if the order was entered by a PA with MOP=25 and confirm receipt.
I PRCR="Y",$P($G(^PRC(442,PRCRI(442),23)),"^",11)="" D I $G(X)=-1 D EXIT QUIT
. D CHKREC I $P($G(^PRCH(440.6,PRCRI(440.6),1)),"^",3)="Y" Q
. D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"43////N")
;
I PRCR="N",$P($G(^PRC(442,PRCRI(442),23)),"^",11)="" D I $G(X)=-1 D EXIT QUIT
. D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),43)
;
;Check old orders where receiving required was not specified by the PA.
I PRCR="",$P($G(^PRC(442,PRCRI(442),23)),"^",11)="" S PRCR="Y" D I $G(X)=-1 D EXIT QUIT
. D CHKREC I $P($G(^PRCH(440.6,PRCRI(440.6),1)),"^",3)="Y" Q
. D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"43////N")
;
;Check PC Direct Delivery Orders. These orders are not received at the
;station.
I PRCR="",$P($G(^PRC(442,PRCRI(442),23)),"^",11)="P" D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"43////Y") I $G(X)=-1 D EXIT QUIT
;
S PRCFOLD=^PRCH(440.6,PRCRI(440.6),1)
W !,"WARNING: If a credit or additional charge is expected against this order number"
W !,"do NOT respond YES."
D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"44;15////R;45////"_DUZ) I $G(X)=-1 D EXIT QUIT
D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"46///T;41////"_PRCRI(442)_";42////"_PRCR)
S PRCRI(410)=$P(^PRC(442,PRCRI(442),0),"^",12),PRCF=$P($G(^(7)),"^",2)
I PRCRI(410) S PRCCOA=$P($G(^PRCS(410,PRCRI(410),4)),"^",8)
I '$G(PRCEDRM) D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"18////"_PRCCOA_";19////"_PRCF)
S PRCF=^PRCH(440.6,PRCRI(440.6),1),PRCST=$S($P(PRCF,U,2)]"":$P(PRCF,U,2),1:"N")_$S($P(PRCF,U,3)]"":$P(PRCF,U,3),1:"N")_$S($P(PRCF,U,4)]"":$P(PRCF,U,4),1:"N")
I $E(PRCST)="N" S PRCSTC=$E("NC",$E(PRCST,2)="Y"+1)_$E(PRCST,3)
E S PRCSTC=$S($D(^PRC(442,PRCRI(442),2,"C"))&$D(^PRC(442,PRCRI(442),11)):"P",'$D(^PRC(442,PRCRI(442),11)):"N",1:"C")_$E(PRCST,3)
S PRCST=$P($T(@PRCSTC),";",3,4),PRCST=$S($D(^PRC(442,PRCRI(442),6)):+$P(PRCST,";",2),1:+$P(PRCST,";"))
D EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),"58///T;.5///"_PRCST)
I $P(PRCF,"^",4)="N" D
. S PRCVAL="" D EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),"44Are you going to dispute this charge amount?//NO;S PRCVAL=X W:X?1""Y"".U !,""You must file a disputed claim form with Purchase Card Company.""")
. I PRCVAL?1"Y".U D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"15////D")
. I $P(PRCFOLD,"^",4)="Y" D ;PRC*5.1*184 Check for Final Charge edit from 'yes' to 'no' to flip RB status in file 410 linked 2237s
.. S PRCRI(410)=0
.. F S PRCRI(410)=$O(^PRC(442,PRCRI(442),13,PRCRI(410))) QUIT:'PRCRI(410) D:PRCRI(410) ERS410^PRC0G(PRCRI(410)_"^A")
.. Q
. QUIT
I $P(PRCF,"^",4)="Y" D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"15////R"),EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),"44////N")
I $P(PRCF,"^",4)="Y",PRCRI(410) D
. N A,B
. S A=0,B=0 F S A=$O(^PRCH(440.6,"PO",PRCRI(442),A)) QUIT:'A S B=B+$P(^PRCH(440.6,A,0),"^",14)
. I B-PRCCOA D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"27////"_B)
. S PRCRI(410)=0
. F S PRCRI(410)=$O(^PRC(442,PRCRI(442),13,PRCRI(410))) QUIT:'PRCRI(410) D:PRCRI(410) ERS410^PRC0G(PRCRI(410)_"^O")
. QUIT
D EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),"20")
S A=$$DDA4406^PRCH0A(PRCRI(440.6)),B=$$DDA442^PRCH0A(PRCRI(442)),$P(B,"^",17)="",PRCBOC=$P(B,"^",21),$P(B,"^",33)=$P(A,"^",33)
I '$G(PRCEDRM),A'=B D
. I $E(PRCB,13,15)>490 D EN^DDIOL("Enter ET-Document by FMS-ON LINE!") QUIT
. D EN^DDIOL("Generating ET-document to FMS...")
. D ET^PRCH8A(.X,PRCRI(440.6)_"^"_PRCRI(442)_"^1^"_PRCBOC,"")
. I X D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"17////"_$P(X,"^"))
. QUIT
EXIT D:$D(IOSTBM) SS(1,24),CS
K FINALDEL,FPARTIAL,PARTIAL
QUIT
;
SS(IOTM,IOBM) ;screen size a-top, b=bottom margin
W @IOSTBM QUIT
;
MC(DX,DY) ;move cursor dx=column #, dy=row number
S DX=DX-1,DY=DY-1 X IOXY QUIT
;
CS W @IOF QUIT
;
CHKREC ;Determine the receiving status of the order
S PARTIAL=+$P($G(^PRC(442,PRCRI(442),11,0)),"^",3) Q:$G(PARTIAL)=0
S:PARTIAL>0 FPARTIAL=$G(^PRC(442,PRCRI(442),11,PARTIAL,0))
S:FPARTIAL]"" FINALDEL=$P($G(FPARTIAL),"^",9)
I FINALDEL["F" D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"43////Y")
Q
;
STATUS ;order status 1-pos:n,p,c for receiving, 2-pos:n,y for final payment
NN ;;39;44
NY ;;24;29
PN ;;46;47
PY ;;32;34
CN ;;48;49
CY ;;50;51
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCH1A3 5656 printed Sep 23, 2025@19:41:08 Page 2
PRCH1A3 ;WISC/PLT-PRCH1A continued ;9/8/98 11:10
V ;;5.1;IFCAP;**184**;Oct 20, 2000;Build 8
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 ;
+3 ;PRC*5.1*184 If Final Charge edited from 'Y' to 'N' add logic to
+4 ; flip the attached 2237s from Running Balance Status
+5 ; 'O' back to 'A' to insure they are carried forward
+6 ; to next fiscal quarter.
+7 ;
+8 ;invalid entry
QUIT
+9 ;
RC ;entry point - prch1d
+1 ;if the order is Simplified or Detailed but receiving is not required,
+2 ;confirm receipt with the user; otherwise check file #442,
+3 ;node 11 before asking the user any questions.
+4 ;
+5 NEW PRCFOLD
+6 SET PRCE=^PRC(442,PRCRI(442),0)
SET PRCCP=$PIECE($GET(^(23)),"^",16)
SET PRCR=$PIECE($GET(^(23)),"^",15)
+7 IF PRCR="N"
IF $PIECE($GET(^PRC(442,PRCRI(442),23)),"^",11)="S"
DO EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),43)
IF $GET(X)=-1
DO EXIT
QUIT
+8 IF PRCR="N"
IF $PIECE($GET(^PRC(442,PRCRI(442),23)),"^",11)="P"
DO EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),43)
IF $GET(X)=-1
DO EXIT
QUIT
+9 ;
+10 IF PRCR="Y"
IF $PIECE($GET(^PRC(442,PRCRI(442),23)),"^",11)="P"
Begin DoDot:1
+11 DO CHKREC
IF $PIECE($GET(^PRCH(440.6,PRCRI(440.6),1)),"^",3)="Y"
QUIT
+12 DO EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"43////N")
IF $GET(X)=-1
DO EXIT
QUIT
End DoDot:1
IF $GET(X)=-1
DO EXIT
QUIT
+13 ;
+14 ;See if the order was entered by a PA with MOP=25 and confirm receipt.
+15 IF PRCR="Y"
IF $PIECE($GET(^PRC(442,PRCRI(442),23)),"^",11)=""
Begin DoDot:1
+16 DO CHKREC
IF $PIECE($GET(^PRCH(440.6,PRCRI(440.6),1)),"^",3)="Y"
QUIT
+17 DO EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"43////N")
End DoDot:1
IF $GET(X)=-1
DO EXIT
QUIT
+18 ;
+19 IF PRCR="N"
IF $PIECE($GET(^PRC(442,PRCRI(442),23)),"^",11)=""
Begin DoDot:1
+20 DO EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),43)
End DoDot:1
IF $GET(X)=-1
DO EXIT
QUIT
+21 ;
+22 ;Check old orders where receiving required was not specified by the PA.
+23 IF PRCR=""
IF $PIECE($GET(^PRC(442,PRCRI(442),23)),"^",11)=""
SET PRCR="Y"
Begin DoDot:1
+24 DO CHKREC
IF $PIECE($GET(^PRCH(440.6,PRCRI(440.6),1)),"^",3)="Y"
QUIT
+25 DO EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"43////N")
End DoDot:1
IF $GET(X)=-1
DO EXIT
QUIT
+26 ;
+27 ;Check PC Direct Delivery Orders. These orders are not received at the
+28 ;station.
+29 IF PRCR=""
IF $PIECE($GET(^PRC(442,PRCRI(442),23)),"^",11)="P"
DO EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"43////Y")
IF $GET(X)=-1
DO EXIT
QUIT
+30 ;
+31 SET PRCFOLD=^PRCH(440.6,PRCRI(440.6),1)
+32 WRITE !,"WARNING: If a credit or additional charge is expected against this order number"
+33 WRITE !,"do NOT respond YES."
+34 DO EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"44;15////R;45////"_DUZ)
IF $GET(X)=-1
DO EXIT
QUIT
+35 DO EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"46///T;41////"_PRCRI(442)_";42////"_PRCR)
+36 SET PRCRI(410)=$PIECE(^PRC(442,PRCRI(442),0),"^",12)
SET PRCF=$PIECE($GET(^(7)),"^",2)
+37 IF PRCRI(410)
SET PRCCOA=$PIECE($GET(^PRCS(410,PRCRI(410),4)),"^",8)
+38 IF '$GET(PRCEDRM)
DO EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"18////"_PRCCOA_";19////"_PRCF)
+39 SET PRCF=^PRCH(440.6,PRCRI(440.6),1)
SET PRCST=$SELECT($PIECE(PRCF,U,2)]"":$PIECE(PRCF,U,2),1:"N")_$SELECT($PIECE(PRCF,U,3)]"":$PIECE(PRCF,U,3),1:"N")_$SELECT($PIECE(PRCF,U,4)]"":$PIECE(PRCF,U,4),1:"N")
+40 IF $EXTRACT(PRCST)="N"
SET PRCSTC=$EXTRACT("NC",$EXTRACT(PRCST,2)="Y"+1)_$EXTRACT(PRCST,3)
+41 IF '$TEST
SET PRCSTC=$SELECT($DATA(^PRC(442,PRCRI(442),2,"C"))&$DATA(^PRC(442,PRCRI(442),11)):"P",'$DATA(^PRC(442,PRCRI(442),11)):"N",1:"C")_$EXTRACT(PRCST,3)
+42 SET PRCST=$PIECE($TEXT(@PRCSTC),";",3,4)
SET PRCST=$SELECT($DATA(^PRC(442,PRCRI(442),6)):+$PIECE(PRCST,";",2),1:+$PIECE(PRCST,";"))
+43 DO EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),"58///T;.5///"_PRCST)
+44 IF $PIECE(PRCF,"^",4)="N"
Begin DoDot:1
+45 SET PRCVAL=""
DO EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),"44Are you going to dispute this charge amount?//NO;S PRCVAL=X W:X?1""Y"".U !,""You must file a disputed claim form with Purchase Card Company.""")
+46 IF PRCVAL?1"Y".U
DO EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"15////D")
+47 ;PRC*5.1*184 Check for Final Charge edit from 'yes' to 'no' to flip RB status in file 410 linked 2237s
IF $PIECE(PRCFOLD,"^",4)="Y"
Begin DoDot:2
+48 SET PRCRI(410)=0
+49 FOR
SET PRCRI(410)=$ORDER(^PRC(442,PRCRI(442),13,PRCRI(410)))
if 'PRCRI(410)
QUIT
if PRCRI(410)
DO ERS410^PRC0G(PRCRI(410)_"^A")
+50 QUIT
End DoDot:2
+51 QUIT
End DoDot:1
+52 IF $PIECE(PRCF,"^",4)="Y"
DO EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"15////R")
DO EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),"44////N")
+53 IF $PIECE(PRCF,"^",4)="Y"
IF PRCRI(410)
Begin DoDot:1
+54 NEW A,B
+55 SET A=0
SET B=0
FOR
SET A=$ORDER(^PRCH(440.6,"PO",PRCRI(442),A))
if 'A
QUIT
SET B=B+$PIECE(^PRCH(440.6,A,0),"^",14)
+56 IF B-PRCCOA
DO EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"27////"_B)
+57 SET PRCRI(410)=0
+58 FOR
SET PRCRI(410)=$ORDER(^PRC(442,PRCRI(442),13,PRCRI(410)))
if 'PRCRI(410)
QUIT
if PRCRI(410)
DO ERS410^PRC0G(PRCRI(410)_"^O")
+59 QUIT
End DoDot:1
+60 DO EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),"20")
+61 SET A=$$DDA4406^PRCH0A(PRCRI(440.6))
SET B=$$DDA442^PRCH0A(PRCRI(442))
SET $PIECE(B,"^",17)=""
SET PRCBOC=$PIECE(B,"^",21)
SET $PIECE(B,"^",33)=$PIECE(A,"^",33)
+62 IF '$GET(PRCEDRM)
IF A'=B
Begin DoDot:1
+63 IF $EXTRACT(PRCB,13,15)>490
DO EN^DDIOL("Enter ET-Document by FMS-ON LINE!")
QUIT
+64 DO EN^DDIOL("Generating ET-document to FMS...")
+65 DO ET^PRCH8A(.X,PRCRI(440.6)_"^"_PRCRI(442)_"^1^"_PRCBOC,"")
+66 IF X
DO EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"17////"_$PIECE(X,"^"))
+67 QUIT
End DoDot:1
EXIT if $DATA(IOSTBM)
DO SS(1,24)
DO CS
+1 KILL FINALDEL,FPARTIAL,PARTIAL
+2 QUIT
+3 ;
SS(IOTM,IOBM) ;screen size a-top, b=bottom margin
+1 WRITE @IOSTBM
QUIT
+2 ;
MC(DX,DY) ;move cursor dx=column #, dy=row number
+1 SET DX=DX-1
SET DY=DY-1
XECUTE IOXY
QUIT
+2 ;
CS WRITE @IOF
QUIT
+1 ;
CHKREC ;Determine the receiving status of the order
+1 SET PARTIAL=+$PIECE($GET(^PRC(442,PRCRI(442),11,0)),"^",3)
if $GET(PARTIAL)=0
QUIT
+2 if PARTIAL>0
SET FPARTIAL=$GET(^PRC(442,PRCRI(442),11,PARTIAL,0))
+3 if FPARTIAL]""
SET FINALDEL=$PIECE($GET(FPARTIAL),"^",9)
+4 IF FINALDEL["F"
DO EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"43////Y")
+5 QUIT
+6 ;
STATUS ;order status 1-pos:n,p,c for receiving, 2-pos:n,y for final payment
NN ;;39;44
NY ;;24;29
PN ;;46;47
PY ;;32;34
CN ;;48;49
CY ;;50;51
+1 ;
