PRCFDE1 ;WISC@ALTOONA/CTB-CONTINUATION OF PRCFDE ;12/2/10 16:13
V ;;5.1;IFCAP;**154**;Oct 20, 2000;Build 5
;Per VHA Directive 2004-038, this routine should not be modified.
K DIC S DIE="^PRCF(421.5,",DA=PRCF("CIDA")
K %DT S X="T" D ^%DT S PRCFD("TODAY")=Y
S DR="[PRCF CI VOUCHER AUDIT]" D ^DIE ;Q:$D(PRCFD("PAY"))
D ENTER^PRCFDCIP
K PRCF("VENDA"),PRCFD("DOI"),PRCFD("PODA"),PRCFD("DOP"),PRCFD("DIR")
K PRCFD("INV TYPE"),PRCF("PTR"),PRCF("DAYS"),PRCF("NAME"),PRCF("X")
K PRCF("PT"),PRCFD("DOD"),ZX
I $D(Y) S X=$S($D(PRCFD("LOGIN")):10,1:0) D STATUS,NA G VEX
D I %<0 D NA S PRCFD("^")="" G VEX
. S %A="Accept invoice for further processing",%B="",%=1 D ^PRCFYN
. Q:%'=2 S %A="Return invoice to vendor",%B="",%=2 D ^PRCFYN
. Q:%<0 S:%=1 %=3
. Q
I %=2 S X=$S($D(PRCFD("LOGIN")):10,1:0) D STATUS,NA G VEX
I %=3 D G VEX
. S DR=25 D ^DIE I X D
. . S DR="24//TODAY;23" D ^DIE,PRCFCHK^PRCFDCI,^PRCFDSUS
. . Q
. S X=3 D STATUS
. Q
G:$D(PRCFD("LOGIN"))&'$D(PRCFD("RECERT")) VEX
I '$P(^PRCF(421.5,PRCF("CIDA"),0),"^",27) G PAYMENT
S %A="Do you wish to forward this invoice for signature at this time",%B="",%=1 D ^PRCFYN
I %'=1 S X=0,PRCF("%")=% D STATUS S X=" <No further action taken.>*" D MSG^PRCFQ S %=PRCF("%") K PRCF("%") S:%<0 PRCFD("^")="" G VEX
S DIE="^PRCF(421.5,",DA=PRCF("CIDA"),DR="[PRCF CI BORROWER]" D ^DIE
I $D(Y) S X=0 D STATUS,NA S PRCFD("^")="" G VEX
S X="Please forward actual invoice to service for signature.*"
D MSG^PRCFQ S X=5 D STATUS
VEX Q
;
PAYMENT S %A="Do you wish to process this item for payment now",%B="",%=1
N PRCYESNO
D ^PRCFYN S PRCYESNO=%
I PRCYESNO=1,$$VIOLATE^PRCFDSOD(PRCF("CIDA"),DUZ) S X=10 D STATUS,NA G PAYX
I PRCYESNO'=1 S X=10 S:%<0 PRCFD("^")="" D STATUS,NA G PAYX
D DIE^PRCFDCI
PAYX Q
STATUS N X1,X2,DA,DIE,DR S X2=X
S X1=$S($D(^PRCF(421.5,PRCF("CIDA"),2))#2:$P(^(2),"^"),1:"")
I X1="" D ST S X="Status is set to '"_Y_"'.*" D MSG^PRCFQ G STATUSX
I X=X1 D ST S X="Status of '"_Y_"' has not been changed.*" D MSG^PRCFQ Q
S X=X1 D ST S $P(X1,"^",2)=Y,X=X2 D ST S $P(X2,"^",2)=Y
S X="Status has been changed from '"_$P(X1,"^",2)_"'*" D MSG^PRCFQ
S X=" to '"_$P(X2,"^",2)_"'.*" D MSG^PRCFQ
I $G(PRCNOPAT)=1 K PRCNOPAT W ?3,"This invoice needs a valid purchase order number.",!!
STATUSX S DA=PRCF("CIDA"),DR="50////^S X=+X2",DIE=421.5 D ^DIE
Q
ST N DD,F S DD=421.5,F=50 D ^PRCFU1 Q
NA S X=" <No action taken.>*" D MSG^PRCFQ Q
OUT ;EXIT LINE
D OUT^PRCFDE Q
EDIT ;EDIT EXISTING, INCOMPLETE INVOICE
S PRCF("X")="AS" D ^PRCFSITE Q:'%
S PRCFD("PAY")="",PRCFDX("ED")="",DIC=421.5,DIC(0)="AEMNZ"
S DIC("S")="I $S('$D(^(2)):1,+^(2)>3:0,1:1),$D(^(1)),$P(^(1),""^"",2)=PRC(""SITE"")"
D ^DIC K DIC I Y<0 K PRCFDX("ED") D OUT Q
S PRCF("CIDA")=+Y D PAT^PRCFDE I $D(PRCFD("^")) D OUT Q
S %A="Do you wish to edit another incomplete invoice",%B="",%=2
D ^PRCFYN G EDIT:%=1 D OUT
Q
;
;
PO ;INPUT TRANSFORM FOR FIELD 4.5 FILE 421.5
;I '$D(PRC("SITE")) S PRCFX=X,PRCF("X")="AS" D ^PRCFSITE S X=PRCFX K PRCFX Q:'%
I X["." S X=$P(X,".")
N DIC,%A,%B S DIC=442,DIC(0)="EM" D ^DIC K DIC
I $D(DTOUT)!($D(DUOUT)) K DTOUT,DUOUT,X Q
I Y>0 S ZY=Y,X=$P($G(^PRC(442,+Y,7)),U,2) I X<10!(X>43) G:X=45 CANC D QUES,^PRCFYN S Y=ZY K ZY I %'=1 K X Q
I $G(PRCF("CIDA"))="" S PRCF("CIDA")=$G(DA)
I Y>0 S X=$P(Y,"^",2),$P(^PRCF(421.5,PRCF("CIDA"),0),"^",7)=+Y,^PRCF(421.5,"E",+Y,PRCF("CIDA"))="" Q
I Y<0,X="" K X Q
S X=$S(X["-":PRC("SITE")_"-"_$P(X,"-",2),1:PRC("SITE")_"-"_X)
S %A=$S(X]"":"PAT Reference Number "_X_" is not in Purchase Order File.",1:"No PAT number selected"),%A(0)="*!",%A(1)="OK to Continue",%B="",%=2 D ^PRCFYN I %'=1 K X Q
I %=1 S PRCNOPAT=1
N PZ
S PZ=$P(^PRCF(421.5,PRCF("CIDA"),0),"^",7),$P(^(0),"^",7)=""
I PZ]"" K ^PRCF(421.5,"E",PZ,PRCF("CIDA")) Q
Q
QUES S X=+$G(^PRC(442,+Y,7))
S X=$S(X="":"UNKNOWN",'$D(^PRCD(442.3,X,0)):"UNKNOWN",1:$P(^(0),"^"))
S %A="Current Status on this PAT number is '"_X_"'. OK to Continue"
S %A(0)="*",%B="",%=2
Q
CANC W !,$C(7),"Purchase Order status is: CANCELED ORDER. Cannot proceed." S Y=ZY,%=-1 K ZY,X Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFDE1 4147 printed Dec 13, 2024@02:02:56 Page 2
PRCFDE1 ;WISC@ALTOONA/CTB-CONTINUATION OF PRCFDE ;12/2/10 16:13
V ;;5.1;IFCAP;**154**;Oct 20, 2000;Build 5
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 KILL DIC
SET DIE="^PRCF(421.5,"
SET DA=PRCF("CIDA")
+3 KILL %DT
SET X="T"
DO ^%DT
SET PRCFD("TODAY")=Y
+4 ;Q:$D(PRCFD("PAY"))
SET DR="[PRCF CI VOUCHER AUDIT]"
DO ^DIE
+5 DO ENTER^PRCFDCIP
+6 KILL PRCF("VENDA"),PRCFD("DOI"),PRCFD("PODA"),PRCFD("DOP"),PRCFD("DIR")
+7 KILL PRCFD("INV TYPE"),PRCF("PTR"),PRCF("DAYS"),PRCF("NAME"),PRCF("X")
+8 KILL PRCF("PT"),PRCFD("DOD"),ZX
+9 IF $DATA(Y)
SET X=$SELECT($DATA(PRCFD("LOGIN")):10,1:0)
DO STATUS
DO NA
GOTO VEX
+10 Begin DoDot:1
+11 SET %A="Accept invoice for further processing"
SET %B=""
SET %=1
DO ^PRCFYN
+12 if %'=2
QUIT
SET %A="Return invoice to vendor"
SET %B=""
SET %=2
DO ^PRCFYN
+13 if %<0
QUIT
if %=1
SET %=3
+14 QUIT
End DoDot:1
IF %<0
DO NA
SET PRCFD("^")=""
GOTO VEX
+15 IF %=2
SET X=$SELECT($DATA(PRCFD("LOGIN")):10,1:0)
DO STATUS
DO NA
GOTO VEX
+16 IF %=3
Begin DoDot:1
+17 SET DR=25
DO ^DIE
IF X
Begin DoDot:2
+18 SET DR="24//TODAY;23"
DO ^DIE
DO PRCFCHK^PRCFDCI
DO ^PRCFDSUS
+19 QUIT
End DoDot:2
+20 SET X=3
DO STATUS
+21 QUIT
End DoDot:1
GOTO VEX
+22 if $DATA(PRCFD("LOGIN"))&'$DATA(PRCFD("RECERT"))
GOTO VEX
+23 IF '$PIECE(^PRCF(421.5,PRCF("CIDA"),0),"^",27)
GOTO PAYMENT
+24 SET %A="Do you wish to forward this invoice for signature at this time"
SET %B=""
SET %=1
DO ^PRCFYN
+25 IF %'=1
SET X=0
SET PRCF("%")=%
DO STATUS
SET X=" <No further action taken.>*"
DO MSG^PRCFQ
SET %=PRCF("%")
KILL PRCF("%")
if %<0
SET PRCFD("^")=""
GOTO VEX
+26 SET DIE="^PRCF(421.5,"
SET DA=PRCF("CIDA")
SET DR="[PRCF CI BORROWER]"
DO ^DIE
+27 IF $DATA(Y)
SET X=0
DO STATUS
DO NA
SET PRCFD("^")=""
GOTO VEX
+28 SET X="Please forward actual invoice to service for signature.*"
+29 DO MSG^PRCFQ
SET X=5
DO STATUS
VEX QUIT
+1 ;
PAYMENT SET %A="Do you wish to process this item for payment now"
SET %B=""
SET %=1
+1 NEW PRCYESNO
+2 DO ^PRCFYN
SET PRCYESNO=%
+3 IF PRCYESNO=1
IF $$VIOLATE^PRCFDSOD(PRCF("CIDA"),DUZ)
SET X=10
DO STATUS
DO NA
GOTO PAYX
+4 IF PRCYESNO'=1
SET X=10
if %<0
SET PRCFD("^")=""
DO STATUS
DO NA
GOTO PAYX
+5 DO DIE^PRCFDCI
PAYX QUIT
STATUS NEW X1,X2,DA,DIE,DR
SET X2=X
+1 SET X1=$SELECT($DATA(^PRCF(421.5,PRCF("CIDA"),2))#2:$PIECE(^(2),"^"),1:"")
+2 IF X1=""
DO ST
SET X="Status is set to '"_Y_"'.*"
DO MSG^PRCFQ
GOTO STATUSX
+3 IF X=X1
DO ST
SET X="Status of '"_Y_"' has not been changed.*"
DO MSG^PRCFQ
QUIT
+4 SET X=X1
DO ST
SET $PIECE(X1,"^",2)=Y
SET X=X2
DO ST
SET $PIECE(X2,"^",2)=Y
+5 SET X="Status has been changed from '"_$PIECE(X1,"^",2)_"'*"
DO MSG^PRCFQ
+6 SET X=" to '"_$PIECE(X2,"^",2)_"'.*"
DO MSG^PRCFQ
+7 IF $GET(PRCNOPAT)=1
KILL PRCNOPAT
WRITE ?3,"This invoice needs a valid purchase order number.",!!
STATUSX SET DA=PRCF("CIDA")
SET DR="50////^S X=+X2"
SET DIE=421.5
DO ^DIE
+1 QUIT
ST NEW DD,F
SET DD=421.5
SET F=50
DO ^PRCFU1
QUIT
NA SET X=" <No action taken.>*"
DO MSG^PRCFQ
QUIT
OUT ;EXIT LINE
+1 DO OUT^PRCFDE
QUIT
EDIT ;EDIT EXISTING, INCOMPLETE INVOICE
+1 SET PRCF("X")="AS"
DO ^PRCFSITE
if '%
QUIT
+2 SET PRCFD("PAY")=""
SET PRCFDX("ED")=""
SET DIC=421.5
SET DIC(0)="AEMNZ"
+3 SET DIC("S")="I $S('$D(^(2)):1,+^(2)>3:0,1:1),$D(^(1)),$P(^(1),""^"",2)=PRC(""SITE"")"
+4 DO ^DIC
KILL DIC
IF Y<0
KILL PRCFDX("ED")
DO OUT
QUIT
+5 SET PRCF("CIDA")=+Y
DO PAT^PRCFDE
IF $DATA(PRCFD("^"))
DO OUT
QUIT
+6 SET %A="Do you wish to edit another incomplete invoice"
SET %B=""
SET %=2
+7 DO ^PRCFYN
if %=1
GOTO EDIT
DO OUT
+8 QUIT
+9 ;
+10 ;
PO ;INPUT TRANSFORM FOR FIELD 4.5 FILE 421.5
+1 ;I '$D(PRC("SITE")) S PRCFX=X,PRCF("X")="AS" D ^PRCFSITE S X=PRCFX K PRCFX Q:'%
+2 IF X["."
SET X=$PIECE(X,".")
+3 NEW DIC,%A,%B
SET DIC=442
SET DIC(0)="EM"
DO ^DIC
KILL DIC
+4 IF $DATA(DTOUT)!($DATA(DUOUT))
KILL DTOUT,DUOUT,X
QUIT
+5 IF Y>0
SET ZY=Y
SET X=$PIECE($GET(^PRC(442,+Y,7)),U,2)
IF X<10!(X>43)
if X=45
GOTO CANC
DO QUES
DO ^PRCFYN
SET Y=ZY
KILL ZY
IF %'=1
KILL X
QUIT
+6 IF $GET(PRCF("CIDA"))=""
SET PRCF("CIDA")=$GET(DA)
+7 IF Y>0
SET X=$PIECE(Y,"^",2)
SET $PIECE(^PRCF(421.5,PRCF("CIDA"),0),"^",7)=+Y
SET ^PRCF(421.5,"E",+Y,PRCF("CIDA"))=""
QUIT
+8 IF Y<0
IF X=""
KILL X
QUIT
+9 SET X=$SELECT(X["-":PRC("SITE")_"-"_$PIECE(X,"-",2),1:PRC("SITE")_"-"_X)
+10 SET %A=$SELECT(X]"":"PAT Reference Number "_X_" is not in Purchase Order File.",1:"No PAT number selected")
SET %A(0)="*!"
SET %A(1)="OK to Continue"
SET %B=""
SET %=2
DO ^PRCFYN
IF %'=1
KILL X
QUIT
+11 IF %=1
SET PRCNOPAT=1
+12 NEW PZ
+13 SET PZ=$PIECE(^PRCF(421.5,PRCF("CIDA"),0),"^",7)
SET $PIECE(^(0),"^",7)=""
+14 IF PZ]""
KILL ^PRCF(421.5,"E",PZ,PRCF("CIDA"))
QUIT
+15 QUIT
QUES SET X=+$GET(^PRC(442,+Y,7))
+1 SET X=$SELECT(X="":"UNKNOWN",'$DATA(^PRCD(442.3,X,0)):"UNKNOWN",1:$PIECE(^(0),"^"))
+2 SET %A="Current Status on this PAT number is '"_X_"'. OK to Continue"
+3 SET %A(0)="*"
SET %B=""
SET %=2
+4 QUIT
CANC WRITE !,$CHAR(7),"Purchase Order status is: CANCELED ORDER. Cannot proceed."
SET Y=ZY
SET %=-1
KILL ZY,X
QUIT
