PRCHINQ ;WISC/AKS-Add/Edit Surrogate Users and inquire Card Info ;6/8/96 13:38
;;5.1;IFCAP;**18,117,126,157,183**;Oct 20, 2000;Build 4
;Per VHA Directive 2004-038, this routine should not be modified.
;
;PRC*5.1*183 Text added to inform user that surrogates lookup/add will
; only show those having access to FCP linked to PCard.
;
QUIT
;
INQ ;Display purchase card information and allow add/editting of users
;
N PRCHDA
S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE"))!($G(X)="^") ;PRC*5.1*183 SITE setup
S DIC="^PRC(440.5,",DIC(0)="AEQM"
S DIC("S")="I $P(^PRC(440.5,+Y,0),U,8)=DUZ"
D ^DIC W !
S (PRCHDA,DA)=+Y,DR="0:49" D EN^DIQ,EN^DDIOL("REPLACEMENT CHARGE CARD NUMBER: "_$P($G(^PRC(440.5,DA,50)),"^")):$P($G(^PRC(440.5,DA,50)),"^")]"" G:Y=-1 EXIT
S %A="Would you like to add/delete a surrogate",%B="",%=2
D ^PRCFYN G:%<1!(%=2) EXIT
;PRC*5.1*183
W !!,?25,"*** ATTENTION ***"
W !,?5,"Adding a new surrogate will now check surrogate name entered"
W !,?5,"for valid access to the Fund Control Point linked to the PCard."
W !,?5,"It will be possible to enter a name search and not find any"
W !,?5,"due to an invalid name entry or user name with no access to"
W !,?5,"Purchase Card FCP.",!
;
MORE ;PRC*5.1*183 New surrogate logic
S DA(1)=PRCHDA,DIC="^PRC(440.5,"_DA(1)_",1,",DIC(0)="AEQL"
S DIC("S")="I +Y'=$P(^PRC(440.5,DA(1),0),U,8)"
D ^DIC K DIC
G:$D(DUOUT)!$D(DTOUT) EXIT G EXIT:Y'>0 S DA=+Y
I $P(Y,U,3)'=1 D
. W !!?5,"Would you like to delete this surrogate user" S %=2 D YN^DICN
. Q:%<1!(%=2)
. S DA=+Y,DIK="^PRC(440.5,"_DA(1)_",1,"
. D ^DIK K Y,DA,DIK
Q S %A="Would you like to add/delete another surrogate",%B="",%=2
D ^PRCFYN G:%<1!(%=2) EXIT G MORE
;
STAT ;Amendment/Adjustment statuses from the dd, called from field #50, sub-
;field #9 of file #443.6
N MOPPC S MOPPC=0
I $P($G(^PRC(443.6,PRCHPO,0)),U,2)=25 S MOPPC=1
S DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=21:1,Z1=23:1,Z1=26:1,Z1=29:1,Z1=31:1,Z1=34:1,Z1=41:1,Z1=44:1,Z1=47:1,Z1=49:1,1:0)"
S:MOPPC DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=21:1,Z1=23:1,Z1=26:1,Z1=29:1,Z1=31:1,Z1=34:1,Z1=44:1,Z1=47:1,Z1=49:1,1:0)"
;I $G(PRCHAUTH)=1 S DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=21:1,Z1=23:1,Z1=26:1,Z1=29:1,Z1=31:1,Z1=34:1,Z1=41:1,Z1=44:1,Z1=47:1,Z1=49:1,Z1=51:1,1:0)"
I $G(PRCHAUTH)=1 D
. S DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=23:1,Z1=26:1,Z1=31:1,1:0)"
. S PRCHOLD=$P($G(^PRC(443.6,PRCHPO,7)),U)
. I $P($G(^PRCD(442.3,PRCHOLD,0)),"(")="Paid " D
. . S DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=29:1,Z1=34:1,Z1=38:1,1:0)"
. I $P($G(^PRCD(442.3,PRCHOLD,0)),"(")="Partial Payment " D
. . S DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=44:1,Z1=47:1,Z1=49:1,1:0)"
D ^DIC K DIC,PRCHOLD,MOPPC S DIC=DIE,X=+Y K:Y<0 X
QUIT
EXIT ;Kill variables and quit
K Y,%A,%B,%,DIC
QUIT
STAT1 ;Called from field #50, subfield #9, file #443.6
N MOPPC S MOPPC=0
I $P($G(^PRC(443.6,PRCHPO,0)),U,2)=25 S MOPPC=1
S DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=21:1,Z1=23:1,Z1=26:1,Z1=29:1,Z1=31:1,Z1=34:1,Z1=41:1,Z1=44:1,Z1=47:1,Z1=49:1,1:0)"
S:MOPPC DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=21:1,Z1=23:1,Z1=26:1,Z1=29:1,Z1=31:1,Z1=34:1,Z1=44:1,Z1=47:1,Z1=49:1,1:0)"
;I $G(PRCHAUTH)=1 S DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=21:1,Z1=23:1,Z1=26:1,Z1=29:1,Z1=31:1,Z1=34:1,Z1=41:1,Z1=44:1,Z1=47:1,Z1=49:1,Z1=51:1,1:0)"
I $G(PRCHAUTH)=1 D
. S DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=23:1,Z1=26:1,Z1=31:1,1:0)"
. S PRCHOLD=$P($G(^PRC(443.6,PRCHPO,7)),U)
. I $P($G(^PRCD(442.3,PRCHOLD,0)),"(")="Paid " D
. . S DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=29:1,Z1=34:1,Z1=38:1,1:0)"
. I $P($G(^PRCD(442.3,PRCHOLD,0)),"(")="Partial Payment " D
. . S DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=44:1,Z1=47:1,Z1=49:1,1:0)"
K PRCHOLD,MOPPC
QUIT
PAID ;To check if there is any payment made for this PO
;PRC*5.1*157 in addition to "Paid" status check, check added to insure there are no reconciliation charges linked to order that should prevent PO cancelling.
I $G(PRCHAUTH)=1!($P(^PRC(442,PRCHPO,0),U,2)=25) D
. S PRCHOLD=$P($G(^PRC(443.6,PRCHPO,7)),U)
. I $P($G(^PRCD(442.3,PRCHOLD,0)),"(")="Paid " S PAID=1
. I $P($G(^PRCD(442.3,PRCHOLD,0)),"(")="Partial Payment " S PAID=1
. I $G(PAID)'=1,$O(^PRCH(440.6,"PO",PRCHPO,0)) S PAID=1
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHINQ 4265 printed Nov 22, 2024@17:18:05 Page 2
PRCHINQ ;WISC/AKS-Add/Edit Surrogate Users and inquire Card Info ;6/8/96 13:38
+1 ;;5.1;IFCAP;**18,117,126,157,183**;Oct 20, 2000;Build 4
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;PRC*5.1*183 Text added to inform user that surrogates lookup/add will
+5 ; only show those having access to FCP linked to PCard.
+6 ;
+7 QUIT
+8 ;
INQ ;Display purchase card information and allow add/editting of users
+1 ;
+2 NEW PRCHDA
+3 ;PRC*5.1*183 SITE setup
SET PRCF("X")="S"
DO ^PRCFSITE
if '$DATA(PRC("SITE"))!($GET(X)="^")
QUIT
+4 SET DIC="^PRC(440.5,"
SET DIC(0)="AEQM"
+5 SET DIC("S")="I $P(^PRC(440.5,+Y,0),U,8)=DUZ"
+6 DO ^DIC
WRITE !
+7 SET (PRCHDA,DA)=+Y
SET DR="0:49"
DO EN^DIQ
if $PIECE($GET(^PRC(440.5,DA,50)),"^")]""
DO EN^DDIOL("REPLACEMENT CHARGE CARD NUMBER: "_$PIECE($GET(^PRC(440.5,DA,50)),"^"))
if Y=-1
GOTO EXIT
+8 SET %A="Would you like to add/delete a surrogate"
SET %B=""
SET %=2
+9 DO ^PRCFYN
if %<1!(%=2)
GOTO EXIT
+10 ;PRC*5.1*183
+11 WRITE !!,?25,"*** ATTENTION ***"
+12 WRITE !,?5,"Adding a new surrogate will now check surrogate name entered"
+13 WRITE !,?5,"for valid access to the Fund Control Point linked to the PCard."
+14 WRITE !,?5,"It will be possible to enter a name search and not find any"
+15 WRITE !,?5,"due to an invalid name entry or user name with no access to"
+16 WRITE !,?5,"Purchase Card FCP.",!
+17 ;
MORE ;PRC*5.1*183 New surrogate logic
+1 SET DA(1)=PRCHDA
SET DIC="^PRC(440.5,"_DA(1)_",1,"
SET DIC(0)="AEQL"
+2 SET DIC("S")="I +Y'=$P(^PRC(440.5,DA(1),0),U,8)"
+3 DO ^DIC
KILL DIC
+4 if $DATA(DUOUT)!$DATA(DTOUT)
GOTO EXIT
if Y'>0
GOTO EXIT
SET DA=+Y
+5 IF $PIECE(Y,U,3)'=1
Begin DoDot:1
+6 WRITE !!?5,"Would you like to delete this surrogate user"
SET %=2
DO YN^DICN
+7 if %<1!(%=2)
QUIT
+8 SET DA=+Y
SET DIK="^PRC(440.5,"_DA(1)_",1,"
+9 DO ^DIK
KILL Y,DA,DIK
End DoDot:1
Q SET %A="Would you like to add/delete another surrogate"
SET %B=""
SET %=2
+1 DO ^PRCFYN
if %<1!(%=2)
GOTO EXIT
GOTO MORE
+2 ;
STAT ;Amendment/Adjustment statuses from the dd, called from field #50, sub-
+1 ;field #9 of file #443.6
+2 NEW MOPPC
SET MOPPC=0
+3 IF $PIECE($GET(^PRC(443.6,PRCHPO,0)),U,2)=25
SET MOPPC=1
+4 SET DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=21:1,Z1=23:1,Z1=26:1,Z1=29:1,Z1=31:1,Z1=34:1,Z1=41:1,Z1=44:1,Z1=47:1,Z1=49:1,1:0)"
+5 if MOPPC
SET DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=21:1,Z1=23:1,Z1=26:1,Z1=29:1,Z1=31:1,Z1=34:1,Z1=44:1,Z1=47:1,Z1=49:1,1:0)"
+6 ;I $G(PRCHAUTH)=1 S DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=21:1,Z1=23:1,Z1=26:1,Z1=29:1,Z1=31:1,Z1=34:1,Z1=41:1,Z1=44:1,Z1=47:1,Z1=49:1,Z1=51:1,1:0)"
+7 IF $GET(PRCHAUTH)=1
Begin DoDot:1
+8 SET DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=23:1,Z1=26:1,Z1=31:1,1:0)"
+9 SET PRCHOLD=$PIECE($GET(^PRC(443.6,PRCHPO,7)),U)
+10 IF $PIECE($GET(^PRCD(442.3,PRCHOLD,0)),"(")="Paid "
Begin DoDot:2
+11 SET DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=29:1,Z1=34:1,Z1=38:1,1:0)"
End DoDot:2
+12 IF $PIECE($GET(^PRCD(442.3,PRCHOLD,0)),"(")="Partial Payment "
Begin DoDot:2
+13 SET DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=44:1,Z1=47:1,Z1=49:1,1:0)"
End DoDot:2
End DoDot:1
+14 DO ^DIC
KILL DIC,PRCHOLD,MOPPC
SET DIC=DIE
SET X=+Y
if Y<0
KILL X
+15 QUIT
EXIT ;Kill variables and quit
+1 KILL Y,%A,%B,%,DIC
+2 QUIT
STAT1 ;Called from field #50, subfield #9, file #443.6
+1 NEW MOPPC
SET MOPPC=0
+2 IF $PIECE($GET(^PRC(443.6,PRCHPO,0)),U,2)=25
SET MOPPC=1
+3 SET DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=21:1,Z1=23:1,Z1=26:1,Z1=29:1,Z1=31:1,Z1=34:1,Z1=41:1,Z1=44:1,Z1=47:1,Z1=49:1,1:0)"
+4 if MOPPC
SET DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=21:1,Z1=23:1,Z1=26:1,Z1=29:1,Z1=31:1,Z1=34:1,Z1=44:1,Z1=47:1,Z1=49:1,1:0)"
+5 ;I $G(PRCHAUTH)=1 S DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=21:1,Z1=23:1,Z1=26:1,Z1=29:1,Z1=31:1,Z1=34:1,Z1=41:1,Z1=44:1,Z1=47:1,Z1=49:1,Z1=51:1,1:0)"
+6 IF $GET(PRCHAUTH)=1
Begin DoDot:1
+7 SET DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=23:1,Z1=26:1,Z1=31:1,1:0)"
+8 SET PRCHOLD=$PIECE($GET(^PRC(443.6,PRCHPO,7)),U)
+9 IF $PIECE($GET(^PRCD(442.3,PRCHOLD,0)),"(")="Paid "
Begin DoDot:2
+10 SET DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=29:1,Z1=34:1,Z1=38:1,1:0)"
End DoDot:2
+11 IF $PIECE($GET(^PRCD(442.3,PRCHOLD,0)),"(")="Partial Payment "
Begin DoDot:2
+12 SET DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=44:1,Z1=47:1,Z1=49:1,1:0)"
End DoDot:2
End DoDot:1
+13 KILL PRCHOLD,MOPPC
+14 QUIT
PAID ;To check if there is any payment made for this PO
+1 ;PRC*5.1*157 in addition to "Paid" status check, check added to insure there are no reconciliation charges linked to order that should prevent PO cancelling.
+2 IF $GET(PRCHAUTH)=1!($PIECE(^PRC(442,PRCHPO,0),U,2)=25)
Begin DoDot:1
+3 SET PRCHOLD=$PIECE($GET(^PRC(443.6,PRCHPO,7)),U)
+4 IF $PIECE($GET(^PRCD(442.3,PRCHOLD,0)),"(")="Paid "
SET PAID=1
+5 IF $PIECE($GET(^PRCD(442.3,PRCHOLD,0)),"(")="Partial Payment "
SET PAID=1
+6 IF $GET(PAID)'=1
IF $ORDER(^PRCH(440.6,"PO",PRCHPO,0))
SET PAID=1
End DoDot:1
+7 QUIT
