PRCHREC4 ;ID/RSD,SF/TKW-CONTINUATION--PROCESS RECEIVING ;[7/6/98 10:03am] [7/6/98 10:15am]
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
PRT ; IF METHOD OF PROCESSING=IMPREST FUNDS, UPDATE CONTROL POINT
; OBLIGATED BALANCE
;I $D(^PRCD(442.5,+$P(^PRC(442,DA,0),U,2),0)),$P(^(0),U,3)=12 D OBL^PRCHNRQ
;
PRT1 ; PRINT RECEIVING REPORT IN WAREHOUSE AND IN FISCAL, EXCEPT FOR
; IMPREST FUNDS, WHICH PRINT WHERE REQUESTED BY USER, OR PROOF
; OF DELIVERY FOR GUARANTEED DELIVERY, WHICH PRINTS ONLY IN FISCAL.
;
G:$D(PRCHPOO) PRTF1
G:$G(MOPCHK)=25 PRT2
I '$P($G(^PRC(442,PRCHPO,24)),U),$D(PRCHIMP) K PRCHQ S PRCHQ("DEST2")="IFR",PRCHQ("DEST")="R",D0=PRCHPO,PRCHQ="^PRCHFPNT",PRCHFPT=PRCHRPT D ^PRCHQUE G PRTF
PRT2 ;
K PRCHQ
I $P(PRC("PARAM"),U,12)="W" S PRCHQ("DEST")="R",D0=PRCHPO,PRCHQ="^PRCHFPNT",PRCHFPT=PRCHRPT D ^PRCHQUE
S DIR("A")="Do you want to print an additional copy"
S DIR("B")="NO"
S DIR(0)="Y"
D ^DIR
K DIR
I Y=1 D
. S D0=PRCHPO
. S PRCHFPT=PRCHRPT
. S PRCHQ("DEST")="R"
. S %ZIS="Q"
. D ^%ZIS
. G:POP FINI
. ;
. ; IF USER WANTS TO QUEUE THE SECOND PRINT -- DO IT.
. ;
. I $D(IO("Q")) D Q
. . S ZTRTN="^PRCHFPNT"
. . S ZTSAVE("PRCHFPT")=""
. . S ZTSAVE("PRCHQ(""DEST"")")=""
. . S ZTSAVE("D0")=""
. . D ^%ZTLOAD
. . D HOME^%ZIS
. . K IO("Q")
. . Q
. ;
. ; USER WANTED TO PRINT THE SECOND COPY LOCALLY.
. ;
. U IO
. D ^PRCHFPNT
. D ^%ZISC
FINI . S:$D(ZTQUEUED) ZTREQ="@"
. Q
;
Q:$G(MOPCHK)=25
;
PRTF Q:$P(PRC("PARAM"),U,8)'="Y"
I '$P($G(^PRC(442,PRCHPO,24)),U) D W Q:%'=1
;I $P(^PRC(442,PRCHPO,0),U,19)=2,$P(^(0),U,2)'=25 D W Q:%'=1
;
PRTF1 I $D(PRCHPOO) S %A="Print a Copy of Proof of Order (Receiving Report) ",%B="Enter 'Y' (YES), to print Proof of Order on Fiscal Receiving Report Printer",%=1 D ^PRCFYN Q:%'=1
S PRCHQ("DEST")="R",PRCHQ("DEST2")="FR",D0=PRCHPO,PRCHQ="^PRCHFPNT",PRCHFPT=PRCHRPT
;I $P($G(^PRC(442,PRCHPO,24)),U) I $P(^PRC(442,PRCHPO,0),U,19)'=2 S PRCHQ("DEST2")=""
D ^PRCHQUE
Q
;
W W !!,"Do you want to also print Receiving Report in FISCAL " S %=1 D YN^DICN Q:%'=0
W !!,"If you wish to allow Fiscal to process this receiving report immediately",!,"without waiting for acceptance by the service, answer 'Y' (yes) to this",!,"question."
G W
WW W !!,"Do you want to print Receiving Report " S %=2 D YN^DICN Q:%'=0
W !!,"Please enter Yes or No."
G WW
;
ENTD ;PROMPT FOR ENTRY OF SCHEDULED DELIVERY DATE.
S PRCHDLVD="" I $D(PRCHRPT),$D(^PRC(442,PRCHPO,11,+PRCHRPT,1)) S PRCHDLVD=$P(^(1),U,8)
S PRCHPONO=$P(^PRC(442,PRCHPO,0),U,1) I '$O(^PRC(442.8,"B",PRCHPONO,0)) G EX
;
E2 W !! D D2 S PRCH="" I PRCHDLVD S Y=PRCHDLVD D DD^%DT S PRCH=Y
W !!,"Enter Scheduled Delivery Date: "_PRCH_"// " R X:DTIME S:'$T!(X["^") (X,PRCHDLVD)="^" S:X="" X=PRCH Q:X=""!(X="^") I X["?" D W2 G E2
S Y=X D ^%DT I '$O(^PRC(442.8,"AF",PRCHPONO,Y,0)) D W2 G E2
S PRCHDLVD=Y D DD^%DT W " "_Y S %A="RIGHT DATE ",%=1 D ^PRCFYN I %'=1 G E2
W !!,"Please wait: " K ^TMP("PRCHREC4",$J) F I=0:0 S I=$O(^PRC(442.8,"AF",PRCHPONO,PRCHDLVD,I)) Q:'I I $D(^PRC(442.8,I,0)) S X=^(0) I $P(X,U,2) S ^TMP("PRCHREC4",$J,$P(X,U,2),I)=$P(X,U,4)_U_$P(X,U,5) W "."
W !!
G EX
;
UPDD ;UPDATE SCHEDULED DELIVERY DATE FIELD
K DIE,DA S DIE="^PRC(442,"_PRCHPO_",11,",DA(1)=PRCHPO,DA=PRCHRPT,DR=".05///"_PRCHDLVD D ^DIE K DIE,DA
Q
;
DSPD ;DISPLAY MULTIPLE DELIVERY DATES
Q:'$D(^PRC(442,DA(1),0)) Q:$P(^(0),U,1)="" S PRCHPONO=$P(^(0),U,1) I '$O(^PRC(442.8,"B",PRCHPONO,0)) G EX
;
D2 W "Scheduled Delivery Dates:",! F I=0:0 S I=$O(^PRC(442.8,"AF",PRCHPONO,I)) Q:'I S Y=I D DD^%DT W " ",Y,!
Q
;
EX K PRCHPONO,I,X,Y
Q
;
W2 W $C(7),!!,"Select from one of the listed Scheduled Delivery Dates!",!!
Q
;
KILL ;CALLED FROM PRCHREC
S:$D(PRCHPOO) PRCFA("PARTIAL")=PRCHRPT
L K DIE,DIC,PRCHES,PRCHFPT,PRCHIMP,PRCHLC,PRCHNM,PRCHNRQ,PRCHR,PRCHRAM,PRCHRAMN,PRCHRD,PRCHRDA,PRCHRDY,PRCHRES,PRCHRFIN,PRCHRIT,PRCHROV,PRCHRPT,PRCHRQ,PRCHRQ1
K PRCHRQ2,PRCHRQ3,PRCHRS,PRCHRT0,PRCHRT,PRCHRT2,PRCHRTP,PRCHX,PRCHDLVD,X1,^TMP("PRCHREC4",$J),ROUTINE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHREC4 4136 printed Dec 13, 2024@02:10:13 Page 2
PRCHREC4 ;ID/RSD,SF/TKW-CONTINUATION--PROCESS RECEIVING ;[7/6/98 10:03am] [7/6/98 10:15am]
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
PRT ; IF METHOD OF PROCESSING=IMPREST FUNDS, UPDATE CONTROL POINT
+1 ; OBLIGATED BALANCE
+2 ;I $D(^PRCD(442.5,+$P(^PRC(442,DA,0),U,2),0)),$P(^(0),U,3)=12 D OBL^PRCHNRQ
+3 ;
PRT1 ; PRINT RECEIVING REPORT IN WAREHOUSE AND IN FISCAL, EXCEPT FOR
+1 ; IMPREST FUNDS, WHICH PRINT WHERE REQUESTED BY USER, OR PROOF
+2 ; OF DELIVERY FOR GUARANTEED DELIVERY, WHICH PRINTS ONLY IN FISCAL.
+3 ;
+4 if $DATA(PRCHPOO)
GOTO PRTF1
+5 if $GET(MOPCHK)=25
GOTO PRT2
+6 IF '$PIECE($GET(^PRC(442,PRCHPO,24)),U)
IF $DATA(PRCHIMP)
KILL PRCHQ
SET PRCHQ("DEST2")="IFR"
SET PRCHQ("DEST")="R"
SET D0=PRCHPO
SET PRCHQ="^PRCHFPNT"
SET PRCHFPT=PRCHRPT
DO ^PRCHQUE
GOTO PRTF
PRT2 ;
+1 KILL PRCHQ
+2 IF $PIECE(PRC("PARAM"),U,12)="W"
SET PRCHQ("DEST")="R"
SET D0=PRCHPO
SET PRCHQ="^PRCHFPNT"
SET PRCHFPT=PRCHRPT
DO ^PRCHQUE
+3 SET DIR("A")="Do you want to print an additional copy"
+4 SET DIR("B")="NO"
+5 SET DIR(0)="Y"
+6 DO ^DIR
+7 KILL DIR
+8 IF Y=1
Begin DoDot:1
+9 SET D0=PRCHPO
+10 SET PRCHFPT=PRCHRPT
+11 SET PRCHQ("DEST")="R"
+12 SET %ZIS="Q"
+13 DO ^%ZIS
+14 if POP
GOTO FINI
+15 ;
+16 ; IF USER WANTS TO QUEUE THE SECOND PRINT -- DO IT.
+17 ;
+18 IF $DATA(IO("Q"))
Begin DoDot:2
+19 SET ZTRTN="^PRCHFPNT"
+20 SET ZTSAVE("PRCHFPT")=""
+21 SET ZTSAVE("PRCHQ(""DEST"")")=""
+22 SET ZTSAVE("D0")=""
+23 DO ^%ZTLOAD
+24 DO HOME^%ZIS
+25 KILL IO("Q")
+26 QUIT
End DoDot:2
QUIT
+27 ;
+28 ; USER WANTED TO PRINT THE SECOND COPY LOCALLY.
+29 ;
+30 USE IO
+31 DO ^PRCHFPNT
+32 DO ^%ZISC
FINI if $DATA(ZTQUEUED)
SET ZTREQ="@"
+1 QUIT
End DoDot:1
+2 ;
+3 if $GET(MOPCHK)=25
QUIT
+4 ;
PRTF if $PIECE(PRC("PARAM"),U,8)'="Y"
QUIT
+1 IF '$PIECE($GET(^PRC(442,PRCHPO,24)),U)
DO W
if %'=1
QUIT
+2 ;I $P(^PRC(442,PRCHPO,0),U,19)=2,$P(^(0),U,2)'=25 D W Q:%'=1
+3 ;
PRTF1 IF $DATA(PRCHPOO)
SET %A="Print a Copy of Proof of Order (Receiving Report) "
SET %B="Enter 'Y' (YES), to print Proof of Order on Fiscal Receiving Report Printer"
SET %=1
DO ^PRCFYN
if %'=1
QUIT
+1 SET PRCHQ("DEST")="R"
SET PRCHQ("DEST2")="FR"
SET D0=PRCHPO
SET PRCHQ="^PRCHFPNT"
SET PRCHFPT=PRCHRPT
+2 ;I $P($G(^PRC(442,PRCHPO,24)),U) I $P(^PRC(442,PRCHPO,0),U,19)'=2 S PRCHQ("DEST2")=""
+3 DO ^PRCHQUE
+4 QUIT
+5 ;
W WRITE !!,"Do you want to also print Receiving Report in FISCAL "
SET %=1
DO YN^DICN
if %'=0
QUIT
+1 WRITE !!,"If you wish to allow Fiscal to process this receiving report immediately",!,"without waiting for acceptance by the service, answer 'Y' (yes) to this",!,"question."
+2 GOTO W
WW WRITE !!,"Do you want to print Receiving Report "
SET %=2
DO YN^DICN
if %'=0
QUIT
+1 WRITE !!,"Please enter Yes or No."
+2 GOTO WW
+3 ;
ENTD ;PROMPT FOR ENTRY OF SCHEDULED DELIVERY DATE.
+1 SET PRCHDLVD=""
IF $DATA(PRCHRPT)
IF $DATA(^PRC(442,PRCHPO,11,+PRCHRPT,1))
SET PRCHDLVD=$PIECE(^(1),U,8)
+2 SET PRCHPONO=$PIECE(^PRC(442,PRCHPO,0),U,1)
IF '$ORDER(^PRC(442.8,"B",PRCHPONO,0))
GOTO EX
+3 ;
E2 WRITE !!
DO D2
SET PRCH=""
IF PRCHDLVD
SET Y=PRCHDLVD
DO DD^%DT
SET PRCH=Y
+1 WRITE !!,"Enter Scheduled Delivery Date: "_PRCH_"// "
READ X:DTIME
if '$TEST!(X["^")
SET (X,PRCHDLVD)="^"
if X=""
SET X=PRCH
if X=""!(X="^")
QUIT
IF X["?"
DO W2
GOTO E2
+2 SET Y=X
DO ^%DT
IF '$ORDER(^PRC(442.8,"AF",PRCHPONO,Y,0))
DO W2
GOTO E2
+3 SET PRCHDLVD=Y
DO DD^%DT
WRITE " "_Y
SET %A="RIGHT DATE "
SET %=1
DO ^PRCFYN
IF %'=1
GOTO E2
+4 WRITE !!,"Please wait: "
KILL ^TMP("PRCHREC4",$JOB)
FOR I=0:0
SET I=$ORDER(^PRC(442.8,"AF",PRCHPONO,PRCHDLVD,I))
if 'I
QUIT
IF $DATA(^PRC(442.8,I,0))
SET X=^(0)
IF $PIECE(X,U,2)
SET ^TMP("PRCHREC4",$JOB,$PIECE(X,U,2),I)=$PIECE(X,U,4)_U_$PIECE(X,U,5)
WRITE "."
+5 WRITE !!
+6 GOTO EX
+7 ;
UPDD ;UPDATE SCHEDULED DELIVERY DATE FIELD
+1 KILL DIE,DA
SET DIE="^PRC(442,"_PRCHPO_",11,"
SET DA(1)=PRCHPO
SET DA=PRCHRPT
SET DR=".05///"_PRCHDLVD
DO ^DIE
KILL DIE,DA
+2 QUIT
+3 ;
DSPD ;DISPLAY MULTIPLE DELIVERY DATES
+1 if '$DATA(^PRC(442,DA(1),0))
QUIT
if $PIECE(^(0),U,1)=""
QUIT
SET PRCHPONO=$PIECE(^(0),U,1)
IF '$ORDER(^PRC(442.8,"B",PRCHPONO,0))
GOTO EX
+2 ;
D2 WRITE "Scheduled Delivery Dates:",!
FOR I=0:0
SET I=$ORDER(^PRC(442.8,"AF",PRCHPONO,I))
if 'I
QUIT
SET Y=I
DO DD^%DT
WRITE " ",Y,!
+1 QUIT
+2 ;
EX KILL PRCHPONO,I,X,Y
+1 QUIT
+2 ;
W2 WRITE $CHAR(7),!!,"Select from one of the listed Scheduled Delivery Dates!",!!
+1 QUIT
+2 ;
KILL ;CALLED FROM PRCHREC
+1 if $DATA(PRCHPOO)
SET PRCFA("PARTIAL")=PRCHRPT
+2 LOCK
KILL DIE,DIC,PRCHES,PRCHFPT,PRCHIMP,PRCHLC,PRCHNM,PRCHNRQ,PRCHR,PRCHRAM,PRCHRAMN,PRCHRD,PRCHRDA,PRCHRDY,PRCHRES,PRCHRFIN,PRCHRIT,PRCHROV,PRCHRPT,PRCHRQ,PRCHRQ1
+3 KILL PRCHRQ2,PRCHRQ3,PRCHRS,PRCHRT0,PRCHRT,PRCHRT2,PRCHRTP,PRCHX,PRCHDLVD,X1,^TMP("PRCHREC4",$JOB),ROUTINE
+4 QUIT
