Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCH1A3

PRCH1A3.m

Go to the documentation of this file.
  1. PRCH1A3 ;WISC/PLT-PRCH1A continued ;9/8/98 11:10
  1. V ;;5.1;IFCAP;**184**;Oct 20, 2000;Build 8
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. ;PRC*5.1*184 If Final Charge edited from 'Y' to 'N' add logic to
  1. ; flip the attached 2237s from Running Balance Status
  1. ; 'O' back to 'A' to insure they are carried forward
  1. ; to next fiscal quarter.
  1. ;
  1. QUIT ;invalid entry
  1. ;
  1. RC ;entry point - prch1d
  1. ;if the order is Simplified or Detailed but receiving is not required,
  1. ;confirm receipt with the user; otherwise check file #442,
  1. ;node 11 before asking the user any questions.
  1. ;
  1. N PRCFOLD
  1. S PRCE=^PRC(442,PRCRI(442),0),PRCCP=$P($G(^(23)),"^",16),PRCR=$P($G(^(23)),"^",15)
  1. 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
  1. 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
  1. ;
  1. I PRCR="Y",$P($G(^PRC(442,PRCRI(442),23)),"^",11)="P" D I $G(X)=-1 D EXIT QUIT
  1. . D CHKREC I $P($G(^PRCH(440.6,PRCRI(440.6),1)),"^",3)="Y" Q
  1. . D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"43////N") I $G(X)=-1 D EXIT QUIT
  1. ;
  1. ;See if the order was entered by a PA with MOP=25 and confirm receipt.
  1. I PRCR="Y",$P($G(^PRC(442,PRCRI(442),23)),"^",11)="" D I $G(X)=-1 D EXIT QUIT
  1. . D CHKREC I $P($G(^PRCH(440.6,PRCRI(440.6),1)),"^",3)="Y" Q
  1. . D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"43////N")
  1. ;
  1. I PRCR="N",$P($G(^PRC(442,PRCRI(442),23)),"^",11)="" D I $G(X)=-1 D EXIT QUIT
  1. . D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),43)
  1. ;
  1. ;Check old orders where receiving required was not specified by the PA.
  1. I PRCR="",$P($G(^PRC(442,PRCRI(442),23)),"^",11)="" S PRCR="Y" D I $G(X)=-1 D EXIT QUIT
  1. . D CHKREC I $P($G(^PRCH(440.6,PRCRI(440.6),1)),"^",3)="Y" Q
  1. . D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"43////N")
  1. ;
  1. ;Check PC Direct Delivery Orders. These orders are not received at the
  1. ;station.
  1. 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
  1. ;
  1. S PRCFOLD=^PRCH(440.6,PRCRI(440.6),1)
  1. W !,"WARNING: If a credit or additional charge is expected against this order number"
  1. W !,"do NOT respond YES."
  1. D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"44;15////R;45////"_DUZ) I $G(X)=-1 D EXIT QUIT
  1. D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"46///T;41////"_PRCRI(442)_";42////"_PRCR)
  1. S PRCRI(410)=$P(^PRC(442,PRCRI(442),0),"^",12),PRCF=$P($G(^(7)),"^",2)
  1. I PRCRI(410) S PRCCOA=$P($G(^PRCS(410,PRCRI(410),4)),"^",8)
  1. I '$G(PRCEDRM) D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"18////"_PRCCOA_";19////"_PRCF)
  1. 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")
  1. I $E(PRCST)="N" S PRCSTC=$E("NC",$E(PRCST,2)="Y"+1)_$E(PRCST,3)
  1. 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)
  1. S PRCST=$P($T(@PRCSTC),";",3,4),PRCST=$S($D(^PRC(442,PRCRI(442),6)):+$P(PRCST,";",2),1:+$P(PRCST,";"))
  1. D EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),"58///T;.5///"_PRCST)
  1. I $P(PRCF,"^",4)="N" D
  1. . 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.""")
  1. . I PRCVAL?1"Y".U D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"15////D")
  1. . 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
  1. .. S PRCRI(410)=0
  1. .. F S PRCRI(410)=$O(^PRC(442,PRCRI(442),13,PRCRI(410))) QUIT:'PRCRI(410) D:PRCRI(410) ERS410^PRC0G(PRCRI(410)_"^A")
  1. .. Q
  1. . QUIT
  1. 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")
  1. I $P(PRCF,"^",4)="Y",PRCRI(410) D
  1. . N A,B
  1. . 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)
  1. . I B-PRCCOA D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"27////"_B)
  1. . S PRCRI(410)=0
  1. . F S PRCRI(410)=$O(^PRC(442,PRCRI(442),13,PRCRI(410))) QUIT:'PRCRI(410) D:PRCRI(410) ERS410^PRC0G(PRCRI(410)_"^O")
  1. . QUIT
  1. D EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),"20")
  1. 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)
  1. I '$G(PRCEDRM),A'=B D
  1. . I $E(PRCB,13,15)>490 D EN^DDIOL("Enter ET-Document by FMS-ON LINE!") QUIT
  1. . D EN^DDIOL("Generating ET-document to FMS...")
  1. . D ET^PRCH8A(.X,PRCRI(440.6)_"^"_PRCRI(442)_"^1^"_PRCBOC,"")
  1. . I X D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"17////"_$P(X,"^"))
  1. . QUIT
  1. EXIT D:$D(IOSTBM) SS(1,24),CS
  1. K FINALDEL,FPARTIAL,PARTIAL
  1. QUIT
  1. ;
  1. SS(IOTM,IOBM) ;screen size a-top, b=bottom margin
  1. W @IOSTBM QUIT
  1. ;
  1. MC(DX,DY) ;move cursor dx=column #, dy=row number
  1. S DX=DX-1,DY=DY-1 X IOXY QUIT
  1. ;
  1. CS W @IOF QUIT
  1. ;
  1. CHKREC ;Determine the receiving status of the order
  1. S PARTIAL=+$P($G(^PRC(442,PRCRI(442),11,0)),"^",3) Q:$G(PARTIAL)=0
  1. S:PARTIAL>0 FPARTIAL=$G(^PRC(442,PRCRI(442),11,PARTIAL,0))
  1. S:FPARTIAL]"" FINALDEL=$P($G(FPARTIAL),"^",9)
  1. I FINALDEL["F" D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"43////Y")
  1. Q
  1. ;
  1. STATUS ;order status 1-pos:n,p,c for receiving, 2-pos:n,y for final payment
  1. NN ;;39;44
  1. NY ;;24;29
  1. PN ;;46;47
  1. PY ;;32;34
  1. CN ;;48;49
  1. CY ;;50;51
  1. ;