- 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 Jan 18, 2025@03:11:39 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