- 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 Feb 18, 2025@23:29:20 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