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

PRCHRPT.m

Go to the documentation of this file.
  1. PRCHRPT ;WIRMFO/RSD/REW,RHD-PRINT OPTIONS ;11/13/00 4:27pm
  1. ;;5.1;IFCAP;**7**;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. ST S PRCF("X")="SP"
  1. D ^PRCFSITE
  1. Q
  1. ;
  1. PO S PRCHP("S")="$P(^(0),U,2)<10!($P(^(0),U,2)=25)"
  1. I $G(PRCHPC) S PRCHP("S")="$P(^(0),U,2)=25" ; <<< Patch 72
  1. I $G(PRCHDELV) S PRCHP("S")="$P($G(^(23)),U,11)=""D"""
  1. S PRCHP("A")="P.O./REQ.NO.: "
  1. D EN3^PRCHPAT
  1. I $D(PRCHPO),$D(^PRC(442,+PRCHPO,0)),$P(^(0),U,2)=8 S PRCHNRQ=1
  1. Q
  1. ;
  1. EN ;REPRINTS ON A&MM PRINTER
  1. D ST
  1. ;
  1. EN0 Q:'$D(PRC("PARAM"))
  1. D PO
  1. Q:'$D(PRCHPO)
  1. I X<10 I '$G(PRCHPC) W " ?? Incorrect Status for this option",$C(7) G EN0
  1. S (DEFPNT,%ZIS("B"))=$S($G(PRCHPC):"",1:$O(^PRC(411,+PRC("SITE"),2,"AC","S8",0)))
  1. N IOP,PL
  1. R S %ZIS="Q"
  1. S %ZIS("A")="Print on what Device: "
  1. D ^%ZIS
  1. I POP>0 D ^%ZISC,QK G EN0
  1. S:'$D(PL) PL=DEFPNT
  1. S PRCHIO=DEFPNT
  1. S NOZTDTH=""
  1. S PRCHQ=1
  1. S D0=PRCHPO
  1. S PRCHQ("DEST")=PL
  1. S X=$S($P(PRC("PARAM"),U,11)=1:1,1:2)
  1. S PRCHQ=$S(X=2:"^PRCHFPNT",1:"^PRCHPNT")
  1. S PRCHREPR=1
  1. I $G(ION)["MESSAGE" S:0 ZTIO=ION_";"_IOST D:0 ^%ZISC D MESS D K G EN0
  1. I PRCHQ="^PRCHPNT",'$D(^PRC(411,+PRC("SITE"),2,"AC","S9")) D W G EN
  1. I $G(IO("Q"))="" D G EN0
  1. . U IO
  1. . D @PRCHQ
  1. . D ^%ZISC
  1. . D K
  1. . Q
  1. S PRCHQ("DEST")=ION
  1. D ^%ZISC,^PRCHQUE,K
  1. G EN0
  1. ;
  1. EN1 ;REPRINTS PO IN FISCAL
  1. D ST
  1. ;
  1. EN10 D PO Q:'$D(PRCHPO) I X<10 W " ?? Incorrect Status for this option",$C(7) G EN10
  1. I X'=10,X'=28,X'=33 W !,$C(7)," Please note the STATUS of this Order--it has already been obligated.",! S %A="Are you sure you want to re-print it ",%=2 D ^PRCFYN Q:%=-1 G:%'=1 EN10
  1. S D0=PRCHPO,PRCHQ="^PRCHFPNT",PRCHREPR=1,PRCHQ("DEST")="F" D ^PRCHQUE,K
  1. G EN10
  1. ;
  1. EN2 ;REPRINT AMENDMENT
  1. D ST
  1. EN20 D PO Q:'$D(PRCHPO) S D0=PRCHPO I '$D(^PRC(442,D0,6,"B")) W !?2,$C(7),"No Amendments for this Order" G EN20
  1. ;
  1. EN21 R !?5,"Amendment number: ",X:DTIME G EN20:X=""!(X["^"),EN2H:$E(X)="?"!('$D(^PRC(442,D0,6,"B",X)))
  1. S D1=X,PRCHQ="^PRCHPAM",PRCHREPR=1 D ^PRCHQUE,K
  1. G EN20
  1. ;
  1. EN2H W !?5,"Enter an amendment number. Choose from: " S X=0 F I=0:1 S X=$O(^PRC(442,D0,6,"B",X)) Q:'X W:I "," W X
  1. G EN21
  1. ;
  1. EN3 ;DISPLAY P.O.
  1. D ST
  1. EN30 D PO Q:'$D(PRCHPO)
  1. I X<10 W $C(7)," >>> Status makes this record non-specifiable here."
  1. S D0=PRCHPO D ^PRCHDP1,K
  1. G EN30
  1. ;
  1. EN4 ;PRINT PO FOR RECEIVING
  1. D ST
  1. EN40 D PO Q:'$D(PRCHPO) I X<10!(X>51) W " ?? Incorrect Status for this option",$C(7) G EN40 ; was > 40, changed per DUB-0397-32163
  1. S Y=0 I $D(^PRC(442,DA,11,0)) S DIC="^PRC(442,DA,11,",DIC(0)="NEAZ",DIC("A")="RECEIVING REPORT DATE: " D ^DIC
  1. S PRCHFPT=$S(Y>0:+Y,1:0),D0=PRCHPO,PRCHQ="^PRCHFPNT",PRCHQ("DEST")="R" D ^PRCHQUE
  1. D K G EN40
  1. ;
  1. EN5 ;FCP BALANCE
  1. D ST
  1. EN50 Q:'$D(PRC("SITE")) I '$D(^PRC(420,PRC("SITE"),1,0)) W !,"No Control Points exists for this station.",$C(7) K PRC Q
  1. S DIC="^PRC(420,"_PRC("SITE")_",1,",DIC(0)="AEMNQZ",DIC("A")="Select CONTROL POINT: " D ^DIC K DIC Q:Y<0 S PRC("CP")=$P($P(Y(0),U,1)," ",1),C1=1
  1. S %DT="AEP",%DT("B")="TODAY",%DT("A")="BALANCE AS OF DATE: " D ^%DT K %DT Q:Y<0
  1. S PRC("QTR")=$P("2^2^2^3^3^3^4^4^4^1^1^1","^",$E(Y,4,5)),PRC("FY")=$E(100+$E(Y,2,3)+$E(Y,4),2,3) S (Z,PRCSZ)=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_PRC("CP")
  1. D QUE^PRCSP1A K C1,DIC,PRC,Z
  1. G EN50
  1. ;
  1. EN6 ;PRINT SF18 QUOTATION FOR BID
  1. D ST G EN60^PRCHRPT7
  1. ;
  1. EN7 ;PRINT/DISPLAY 2237
  1. S DIC="^PRCS(410,",DIC(0)="AEMQZ",DIC("A")="2237 REFERENCE NUMBER: ",DIC("S")="I $P(^(0),U,4)'=1,$P(^(0),U,2)=""O""!($P(^(0),U,2)=""CA"")"
  1. D ^PRCSDIC K DIC Q:Y<0 S D0=+Y,PRC("SITE")=+Y(0) W ! D ^PRCHDR K D0 W !!
  1. G EN7
  1. ;
  1. EN8 ;DISPLAY ITEM INFORMATION
  1. W ! S DIC="^PRC(441,",DIC(0)="AEMQ" D ^DIC K DIC Q:Y<0 S DA=+Y,DIQ(0)="C",DIC="^PRC(441," D EN^DIQ K DIC,DIQ,DA,D0
  1. G EN8
  1. ;
  1. QK N DEFPNT
  1. K K DEFPNT,ZTSK,ZTSAVE,ZTDTH,ZTRTN,PRCHREPR,PRCHNRQ,OK,PL,PRCHQ
  1. K X,Y,I
  1. Q
  1. ;
  1. W W $C(7),!!,"You are set up to print the P.O.'s on preprinted forms, but you have not",!,"defined printer 'S9 SUPPLY 2139' on the Site Paramater File.",!
  1. W "This printer MUST be defined to print the second and subsequent pages.",!,"of the Purchase Order."
  1. Q
  1. ;
  1. X W $C(7),!!,"Your printer selection is not defined in the site parameter file."
  1. Q
  1. ;
  1. MESS ;Put message into report
  1. N XMDUZ,XMN,AA S XMDUZ=DUZ,XMN=0
  1. D DES^XMA21 Q:$S($O(XMY(""))="":1,$E($G(X))["^":1,1:0)
  1. W ! S AA=X D ENTS S XMSUB=X S X=AA
  1. I X="" S ZTRTN="ZTSK^PRCHRPT",ZTSAVE("XMY(")="",ZTSAVE("D0")="",ZTSAVE("U")="",ZTSAVE("PRCHQ(""DEST"")")="",ZTSAVE("XMSUB")="",ZTDTH=$H
  1. I S ZTSAVE("PRC(""SITE"")")="" D ^%ZTLOAD
  1. ;
  1. CLN K XMY,XMN,XMDUZ,XMSUB
  1. G K
  1. ;
  1. ZTSK ;
  1. I '$D(XMDUZ),$D(DUZ),DUZ S XMDUZ=DUZ
  1. I 'XMDUZ S XMDUZ=.5
  1. D ^PRCHFPNT W:'$D(ZTQUEUED) !
  1. Q
  1. ENTS ;ASK SUBJECT
  1. S I $D(XMSUB) S Y=XMSUB
  1. W !,"Subject: " G F:'$D(XMSUB) S I=XMSUB
  1. I I["~U~" S I=$$DECODEUP^XMCU1(I)
  1. I $L(I) W I,"//"
  1. F R X:DTIME S:'$T X="^" S:X="" X=$S($D(XMSUB):XMSUB,1:"^") S Y=X
  1. Q:Y=U S (X,Y)=$$ENT^XMGAPI0(Y,1) G S:+X S (X,Y)=$P(X,U,2)
  1. Q