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