PRCHUSER ;WISC/AKS-Add/Edit purchase card user ;9/12/00 22:52
;;5.1;IFCAP;**8,125,165**;Oct 20, 2000;Build 12
;Per VHA Directive 2004-038, this routine should not be modified.
N DIC,DA,Y,DIE,DR,PRCF,%,PRCHORIG,PRCRI
S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE")) Q:$G(X)="^"
MORE S DIC="^PRC(440.5,",DIC(0)="AELQM",DLAYGO=440.5
S DIC("S")="I $D(PRC(""SITE"")),$P($G(^PRC(440.5,+Y,2)),""^"",3)=PRC(""SITE"")"
D ^DIC Q:Y'>0 S DA=+Y,PRCRI(440.5)=DA,PRCIEN=DA
N SITECHK S SITECHK=$P($G(^PRC(440.5,DA,2)),U,3) I +SITECHK'=0,SITECHK'=PRC("SITE") W !!,"This card is not entered for this station." H 3 G MORE
S DIE="^PRC(440.5,",DR="[PRCH PURCHASE CARD]" D ^DIE ;Q:$D(Y)
D EDIT^PRC0B(.X,"440.5;^PRC(440.5,;"_PRCRI(440.5),"70////P;71////"_DT)
K PRCHHLDR,PRCHAPP,PRCHALT,PRCHSING,PRCHMNTH
I '$G(DA) G Q
S DA(1)=DA S PRCHUSER=$P(^PRC(440.5,DA,0),U,8)
I $G(PRCHUSER),$G(PRCHORIG),PRCHUSER'=PRCHORIG D
. S DIK="^PRC(440.5,"_DA(1)_",1,",DA=PRCHORIG D ^DIK K Y,DIK
I $G(PRCHUSER),'$D(^PRC(440.5,DA,1,PRCHUSER)) D
. I '$G(^PRC(440.5,DA(1),1,0)) D
. . S $P(^PRC(440.5,DA(1),1,0),U,2)=$P(^DD(440.5,12,0),U,2)
. S DIE="^PRC(440.5,"_DA(1)_",1,",DA=PRCHUSER,DR=".01////^S X=PRCHUSER"
. D ^DIE
. S $P(^PRC(440.5,DA(1),1,0),U,3)=DA,$P(^(0),U,4)=$P(^(0),U,4)+1
. K DIE,DR,PRCHUSER
;PRC*5.1*165 Text added to inform user that surrogates lookup/add will only
; show those having access to FCP linked to PCard.
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.",!
MORES S:'$D(DA(1)) DA(1)=DA S DIC="^PRC(440.5,"_DA(1)_",1,",DIC(0)="AELQ"
S DIC("S")="I +Y'=$P(^PRC(440.5,DA(1),0),U,8)" D ^DIC
G:$D(DUOUT)!$D(DTOUT) Q G REPL: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,DIK
G MORES
REPL ;REPLACEMENT CARD ENTRY
D NOW^%DTC S XNOW=X
K DIR
S PRCRPLO=$P($G(^PRC(440.5,PRCIEN,50)),U)
REPL1 S DIR("A")="REPLACED CARD: " S:PRCRPLO'="" DIR("B")=PRCRPLO S DIR("?")="Enter a valid card number for replaced card, 16 digits",DIR(0)="FAO^16:16"
D ^DIR G Q:$D(DIRUT)!$D(DTOUT) S PRCRPLN=X K DIR
I PRCRPLN'?1.N W " Must be 16 digits!!" G REPL1
I PRCRPLO=PRCRPLN!'PRCRPLN G Q
S PRCRIENN=$O(^PRC(440.5,"B",PRCRPLN,0)) I 'PRCRIENN W " Not a valid Purchase Card number" G REPL
I $P(^PRC(440.5,PRCRIENN,2),U,2)'="Y" W " Replaced Card Must be INACTIVE" G REPL
S PRCIENP=$O(^PRC(440.5,"ARPC",PRCRPLN,0)) I PRCIENP W " Replaced Card already listed under card: ",$P(^PRC(440.5,PRCIENP,0),U) G REPL
S ERR="" D I ERR'="" W !," >> Replaced card does not match this card for: ",ERR G REPL
. S PRCUR0=^PRC(440.5,PRCIEN,0),PRCUR2=^PRC(440.5,PRCIEN,2),PRCRPL0=$G(^PRC(440.5,PRCRIENN,0)),PRCRPL2=$G(^PRC(440.5,PRCRIENN,2))
. I $P(PRCUR0,U,8)'=$P(PRCRPL0,U,8) S ERR="CARD HOLDER"
. I $P(PRCUR0,U,2)'=$P(PRCRPL0,U,2) S:ERR'="" ERR=ERR_"," S ERR=ERR_"FUND CONTROL POINT"
. I $P(PRCUR0,U,3)'=$P(PRCRPL0,U,3) S:ERR'="" ERR=ERR_"," S ERR=ERR_"COST CENTER"
. I $P(PRCUR0,U,4)'=$P(PRCRPL0,U,4) S:ERR'="" ERR=ERR_"," S ERR=ERR_"BUDGET OBJECT CODE"
. I $P(PRCUR2,U,3)'=$P(PRCRPL2,U,3) S:ERR'="" ERR=ERR_"," S ERR=ERR_"STATION NUMBER"
K DIE S DIE="^PRC(440.5,",DA=PRCIEN,DR="51///^S X=PRCRPLN" D ^DIE K DIE,DA,DR
Q W !!?5,"Would you like to register another purchase card" S %=2 D YN^DICN
W ! G:%=1 MORE I %=0 W !!,"Please answer 'Yes' or 'No'"
K DLAYGO,DA,PRCRPLO,DIR,PRCRPLN,PRCIEN,PRCRIENN,PRCIENP,ERR,PRCUR0,PRCUR2,PRCRPL0,PRCRPL2,XNOW,DIRUT,DTOUT,DIK,DUOUT,DIROUT
QUIT
INPUT1 ;Input transform for File #440.5, Field #1
S DIC="^PRC(420,PRC(""SITE""),1,",DIC(0)="QEMNZ" S DIC("S")="I $D(^PRC(420,""C"",PRCHHLDR,PRC(""SITE""),+Y))",D="B^C" D MIX^DIC1 K:Y<0 X K DIC,D
Q:'$D(X) S X=$P(Y(0),U)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHUSER 4089 printed Nov 22, 2024@17:21:30 Page 2
PRCHUSER ;WISC/AKS-Add/Edit purchase card user ;9/12/00 22:52
+1 ;;5.1;IFCAP;**8,125,165**;Oct 20, 2000;Build 12
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 NEW DIC,DA,Y,DIE,DR,PRCF,%,PRCHORIG,PRCRI
+4 SET PRCF("X")="S"
DO ^PRCFSITE
if '$DATA(PRC("SITE"))
QUIT
if $GET(X)="^"
QUIT
MORE SET DIC="^PRC(440.5,"
SET DIC(0)="AELQM"
SET DLAYGO=440.5
+1 SET DIC("S")="I $D(PRC(""SITE"")),$P($G(^PRC(440.5,+Y,2)),""^"",3)=PRC(""SITE"")"
+2 DO ^DIC
if Y'>0
QUIT
SET DA=+Y
SET PRCRI(440.5)=DA
SET PRCIEN=DA
+3 NEW SITECHK
SET SITECHK=$PIECE($GET(^PRC(440.5,DA,2)),U,3)
IF +SITECHK'=0
IF SITECHK'=PRC("SITE")
WRITE !!,"This card is not entered for this station."
HANG 3
GOTO MORE
+4 ;Q:$D(Y)
SET DIE="^PRC(440.5,"
SET DR="[PRCH PURCHASE CARD]"
DO ^DIE
+5 DO EDIT^PRC0B(.X,"440.5;^PRC(440.5,;"_PRCRI(440.5),"70////P;71////"_DT)
+6 KILL PRCHHLDR,PRCHAPP,PRCHALT,PRCHSING,PRCHMNTH
+7 IF '$GET(DA)
GOTO Q
+8 SET DA(1)=DA
SET PRCHUSER=$PIECE(^PRC(440.5,DA,0),U,8)
+9 IF $GET(PRCHUSER)
IF $GET(PRCHORIG)
IF PRCHUSER'=PRCHORIG
Begin DoDot:1
+10 SET DIK="^PRC(440.5,"_DA(1)_",1,"
SET DA=PRCHORIG
DO ^DIK
KILL Y,DIK
End DoDot:1
+11 IF $GET(PRCHUSER)
IF '$DATA(^PRC(440.5,DA,1,PRCHUSER))
Begin DoDot:1
+12 IF '$GET(^PRC(440.5,DA(1),1,0))
Begin DoDot:2
+13 SET $PIECE(^PRC(440.5,DA(1),1,0),U,2)=$PIECE(^DD(440.5,12,0),U,2)
End DoDot:2
+14 SET DIE="^PRC(440.5,"_DA(1)_",1,"
SET DA=PRCHUSER
SET DR=".01////^S X=PRCHUSER"
+15 DO ^DIE
+16 SET $PIECE(^PRC(440.5,DA(1),1,0),U,3)=DA
SET $PIECE(^(0),U,4)=$PIECE(^(0),U,4)+1
+17 KILL DIE,DR,PRCHUSER
End DoDot:1
+18 ;PRC*5.1*165 Text added to inform user that surrogates lookup/add will only
+19 ; show those having access to FCP linked to PCard.
+20 WRITE !!,?25,"*** ATTENTION ***"
+21 WRITE !,?5,"Adding a new surrogate will now check surrogate name entered"
+22 WRITE !,?5,"for valid access to the Fund Control Point linked to the PCard."
+23 WRITE !,?5,"It will be possible to enter a name search and not find any"
+24 WRITE !,?5,"due to an invalid name entry or user name with no access to"
+25 WRITE !,?5,"Purchase Card FCP.",!
MORES if '$DATA(DA(1))
SET DA(1)=DA
SET DIC="^PRC(440.5,"_DA(1)_",1,"
SET DIC(0)="AELQ"
+1 SET DIC("S")="I +Y'=$P(^PRC(440.5,DA(1),0),U,8)"
DO ^DIC
+2 if $DATA(DUOUT)!$DATA(DTOUT)
GOTO Q
if Y'>0
GOTO REPL
SET DA=+Y
+3 IF $PIECE(Y,U,3)'=1
Begin DoDot:1
+4 WRITE !!?5,"Would you like to delete this surrogate user"
SET %=2
DO YN^DICN
+5 if %<1!(%=2)
QUIT
+6 SET DA=+Y
SET DIK="^PRC(440.5,"_DA(1)_",1,"
+7 DO ^DIK
KILL Y,DIK
End DoDot:1
+8 GOTO MORES
REPL ;REPLACEMENT CARD ENTRY
+1 DO NOW^%DTC
SET XNOW=X
+2 KILL DIR
+3 SET PRCRPLO=$PIECE($GET(^PRC(440.5,PRCIEN,50)),U)
REPL1 SET DIR("A")="REPLACED CARD: "
if PRCRPLO'=""
SET DIR("B")=PRCRPLO
SET DIR("?")="Enter a valid card number for replaced card, 16 digits"
SET DIR(0)="FAO^16:16"
+1 DO ^DIR
if $DATA(DIRUT)!$DATA(DTOUT)
GOTO Q
SET PRCRPLN=X
KILL DIR
+2 IF PRCRPLN'?1.N
WRITE " Must be 16 digits!!"
GOTO REPL1
+3 IF PRCRPLO=PRCRPLN!'PRCRPLN
GOTO Q
+4 SET PRCRIENN=$ORDER(^PRC(440.5,"B",PRCRPLN,0))
IF 'PRCRIENN
WRITE " Not a valid Purchase Card number"
GOTO REPL
+5 IF $PIECE(^PRC(440.5,PRCRIENN,2),U,2)'="Y"
WRITE " Replaced Card Must be INACTIVE"
GOTO REPL
+6 SET PRCIENP=$ORDER(^PRC(440.5,"ARPC",PRCRPLN,0))
IF PRCIENP
WRITE " Replaced Card already listed under card: ",$PIECE(^PRC(440.5,PRCIENP,0),U)
GOTO REPL
+7 SET ERR=""
Begin DoDot:1
+8 SET PRCUR0=^PRC(440.5,PRCIEN,0)
SET PRCUR2=^PRC(440.5,PRCIEN,2)
SET PRCRPL0=$GET(^PRC(440.5,PRCRIENN,0))
SET PRCRPL2=$GET(^PRC(440.5,PRCRIENN,2))
+9 IF $PIECE(PRCUR0,U,8)'=$PIECE(PRCRPL0,U,8)
SET ERR="CARD HOLDER"
+10 IF $PIECE(PRCUR0,U,2)'=$PIECE(PRCRPL0,U,2)
if ERR'=""
SET ERR=ERR_","
SET ERR=ERR_"FUND CONTROL POINT"
+11 IF $PIECE(PRCUR0,U,3)'=$PIECE(PRCRPL0,U,3)
if ERR'=""
SET ERR=ERR_","
SET ERR=ERR_"COST CENTER"
+12 IF $PIECE(PRCUR0,U,4)'=$PIECE(PRCRPL0,U,4)
if ERR'=""
SET ERR=ERR_","
SET ERR=ERR_"BUDGET OBJECT CODE"
+13 IF $PIECE(PRCUR2,U,3)'=$PIECE(PRCRPL2,U,3)
if ERR'=""
SET ERR=ERR_","
SET ERR=ERR_"STATION NUMBER"
End DoDot:1
IF ERR'=""
WRITE !," >> Replaced card does not match this card for: ",ERR
GOTO REPL
+14 KILL DIE
SET DIE="^PRC(440.5,"
SET DA=PRCIEN
SET DR="51///^S X=PRCRPLN"
DO ^DIE
KILL DIE,DA,DR
Q WRITE !!?5,"Would you like to register another purchase card"
SET %=2
DO YN^DICN
+1 WRITE !
if %=1
GOTO MORE
IF %=0
WRITE !!,"Please answer 'Yes' or 'No'"
+2 KILL DLAYGO,DA,PRCRPLO,DIR,PRCRPLN,PRCIEN,PRCRIENN,PRCIENP,ERR,PRCUR0,PRCUR2,PRCRPL0,PRCRPL2,XNOW,DIRUT,DTOUT,DIK,DUOUT,DIROUT
+3 QUIT
INPUT1 ;Input transform for File #440.5, Field #1
+1 SET DIC="^PRC(420,PRC(""SITE""),1,"
SET DIC(0)="QEMNZ"
SET DIC("S")="I $D(^PRC(420,""C"",PRCHHLDR,PRC(""SITE""),+Y))"
SET D="B^C"
DO MIX^DIC1
if Y<0
KILL X
KILL DIC,D
+2 if '$DATA(X)
QUIT
SET X=$PIECE(Y(0),U)
+3 QUIT
