- 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 Mar 13, 2025@21:16:12 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
