- 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 Jan 18, 2025@03:06:16 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 ;