PRCSPC ;WISC/KMB-PURCHASE CARD UPDATE CP FILES ;2/17/98 @ 1:02 PM
;;5.1;IFCAP;**35**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
; quit if entry point not used
Q
;
COMM(DA,SDATE) ; set committed balance for PC order with no 2237
Q:DA']""
N AMT,FCP,FY,NODE,QT,STR,X S NODE=$G(^PRC(442,DA,0)) Q:NODE=""
S CDA=$P(NODE,"^",12)
S STA=+$P(NODE," -"),AMT=$P(NODE,"^",16),FCP=$P(NODE,"^",3),FCP=$P(FCP," ")
I CDA'="" D UPDATE
D NOW^%DTC
S FY=$E(X,2,3)
S QT=$E(X,4,5)
S QT=$P("2^2^2^3^3^3^4^4^4^1^1^1","^",+QT)
S:QT=1 FY=$E(($E(X,1,3)+1),2,3)
S STR=STA_"^"_FCP_"^"_FY_"^"_QT_"^"_AMT
D EBAL^PRCSEZ(STR,"C")
Q
;
UPDATE ;
Q:CDA']""
N I,X,MESSAGE,STRING,TDA
Q:'$D(^PRCS(410,CDA,4)) S NODE(0)=^PRCS(410,CDA,0)
S TDA=DA,DA=CDA,X=$P(^PRCS(410,CDA,4),"^",8) D TRANK^PRCSES
S DA=TDA D NOW^%DTC S $P(^PRCS(410,CDA,4),"^",4)=X
S $P(^PRCS(410,CDA,9),"^",2)=SDATE
F I=1,8 S $P(^PRCS(410,CDA,4),"^",I)=AMT
D ERS410^PRC0G(CDA_"^A")
S MESSAGE="" D ENCODE^PRCSC2(CDA,DUZ,.MESSAGE)
I MESSAGE<1 W !,"Contact your Site manager for an electronic signature code" Q
Q
;
LOOK ; lookup for purchase card orders
Q:'$D(DA)
S (PRCHCDNO,PRCHXXX)=$P($G(^PRC(442,DA,23)),"^",8)
N TIMES,START,END,EN,STA,FIN,REM,ORIG,A1,A2,AA,ERROR,FLAG,VALUE,VALUE1,COUNT,TEMP,I,J,STR,XXZ
S FLAG=0
D ARR
S VALUE1=+$P($G(^PRC(442,DA,23)),"^",8)
I VALUE1=0,COUNT=1 S VALUE1=$P(AA(DUZ,1),"^",3),FLAG=1
W !,"PURCHASE CARD NAME: ",$P($G(^PRC(440.5,VALUE1,0)),"^",11),$S(VALUE1=0:"",1:"//") R XXZ:DTIME
I XXZ="",VALUE1'=0 W " ",$P($G(^PRC(440.5,VALUE1,0)),"^",11) S XXZ=FLAG D SET Q:$G(ERROR)="" G LOOK
I XXZ=" ",VALUE1'=0 W " ",$P($G(^PRC(440.5,VALUE1,0)),"^",11) S XXZ=FLAG D SET Q:$G(ERROR)="" G LOOK
;
; Allow user to get out gracefully.
I XXZ="" S X=XXZ W !!,?5,"No card selected...",$C(7) Q
I XXZ["^" S X=XXZ W !!,?5,"Card selection interrupted...",$C(7) Q
I XXZ["?",'$D(AA(DUZ,1)) W !,"You are not a purchase card holder." Q
S VALUE="" I XXZ["?" D I VALUE="" W "??" G LOOK
.D LOOK1
.I XXZ=""!(XXZ["^") S VALUE="" Q
.I '$D(AA(DUZ,XXZ)) S VALUE="" Q
.W " ",$P(AA(DUZ,XXZ),"^",2)
.D SET S:$G(ERROR)'="" VALUE=""
Q:VALUE=1
;
TESTL ;
I XXZ?1.6N D I VALUE="" W "??" G LOOK
.D LOOK1
.I XXZ=""!(XXZ["^") S VALUE="" Q
.I '$D(J(XXZ)) S VALUE="" Q
.W " ",$P(AA(DUZ,XXZ),"^",2)
.D SET S:$G(ERROR)'="" VALUE=""
Q:VALUE=1
D LOOK1
I VALUE'=1 W " ??" G LOOK
I (XXZ["^")!(XXZ="") W " ??" G LOOK
I '$D(J(XXZ)) W "??" G LOOK
W " ",$P(AA(DUZ,XXZ),"^",2) D SET I $G(ERROR)'="" G LOOK
Q
;
SET I XXZ=0 S ERROR=1 Q
S TEMP=$P(AA(DUZ,XXZ),"^",3)
S VALUE=1
I $P($G(^PRC(440.5,TEMP,2)),U,2)="Y" W ?50,"Inactive Purchase Card.",! S ERROR=1,VALUE="" K TEMP Q
S PRCHXXX=TEMP
Q
;
; Prevent use of card if it is inactive, or the approving official is
; missing, or the card has expired.
ARR S (COUNT,I)=0 F S I=$O(^PRC(440.5,"C",DUZ,I)) Q:I="" D
.Q:$P($G(^PRC(440.5,I,2)),U,2)="Y"!($P($G(^PRC(440.5,I,0)),"^",9)="")
.I $P(^PRC(440.5,I,2),U,4)]"" Q:$P($G(^PRC(440.5,I,2)),U,4)<DT
.S COUNT=COUNT+1,STR=$P($G(^PRC(440.5,I,0)),"^",1),STR1=$P($G(^PRC(440.5,I,0)),"^",11)
.I I=+$P($G(^PRC(442,DA,23)),"^",8) S FLAG=COUNT
.S AA(DUZ,COUNT)=STR_"^"_STR1_"^"_I
S REM=COUNT#20,END=COUNT-REM,TIMES=END/20
Q
;
LOOK1 ;
K J S OUT="" S ORIG=XXZ S:ORIG["?" ORIG="" S:TIMES=0 TIMES=1
N BB,VAL,ZZ I ORIG'="" S VAL=0 F ZZ=1:1:COUNT D
.I $P(AA(DUZ,ZZ),"^",2)[ORIG S VAL=VAL+1,BB=ZZ
I $G(VAL)=1 S J(BB)=1,VALUE=1,XXZ=BB,OUT=1 Q
S STA=0 F J=1:1:TIMES Q:$G(OUT)=1 D Q:$G(OUT)=1
.S START=1+((J-1)*20),EN=J*20 S:COUNT<20 EN=COUNT
.F I=START:1:EN I $P(AA(DUZ,I),"^",2)[ORIG S J(I)=1,VALUE=1 W !,I,?5,$P(AA(DUZ,I),"^",2)
.F I=START:1:EN I $G(J(I))=1 S FIN=I I STA=0 S STA=I
.I $G(VALUE)=1 W !,"CHOOSE ",STA,"-",FIN,": " R XXZ:DTIME I '$T S OUT=1
.I XXZ'="",XXZ>COUNT S OUT=1
.I XXZ'="",XXZ'>EN S OUT=1
Q:$G(OUT)=1
I COUNT<20 Q
K J S VALUE="" F I=END+1:1:COUNT I $P(AA(DUZ,I),"^",2)[ORIG S J(I)=1,VALUE=1 W !,I,?5,$P(AA(DUZ,I),"^",2)
F I=END+1:1:COUNT I $G(J(I))=1 S FIN=I
I $G(VALUE)=1 W !,"CHOOSE ",STA,"-",FIN,": " R XXZ:DTIME I XXZ'=""!'$T S OUT=1
Q
;
REF ;Stop users atempting to enter a past date and clean up the P.O. DATE
;field and its cross reference, "AB".
S PRCHX=@"^DD(442,.1,1,1,2)" X PRCHX K PRCHX
S $P(^PRC(442,DA,1),"^",15)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSPC 4402 printed Oct 16, 2024@18:19 Page 2
PRCSPC ;WISC/KMB-PURCHASE CARD UPDATE CP FILES ;2/17/98 @ 1:02 PM
+1 ;;5.1;IFCAP;**35**;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ; quit if entry point not used
+4 QUIT
+5 ;
COMM(DA,SDATE) ; set committed balance for PC order with no 2237
+1 if DA']""
QUIT
+2 NEW AMT,FCP,FY,NODE,QT,STR,X
SET NODE=$GET(^PRC(442,DA,0))
if NODE=""
QUIT
+3 SET CDA=$PIECE(NODE,"^",12)
+4 SET STA=+$PIECE(NODE," -")
SET AMT=$PIECE(NODE,"^",16)
SET FCP=$PIECE(NODE,"^",3)
SET FCP=$PIECE(FCP," ")
+5 IF CDA'=""
DO UPDATE
+6 DO NOW^%DTC
+7 SET FY=$EXTRACT(X,2,3)
+8 SET QT=$EXTRACT(X,4,5)
+9 SET QT=$PIECE("2^2^2^3^3^3^4^4^4^1^1^1","^",+QT)
+10 if QT=1
SET FY=$EXTRACT(($EXTRACT(X,1,3)+1),2,3)
+11 SET STR=STA_"^"_FCP_"^"_FY_"^"_QT_"^"_AMT
+12 DO EBAL^PRCSEZ(STR,"C")
+13 QUIT
+14 ;
UPDATE ;
+1 if CDA']""
QUIT
+2 NEW I,X,MESSAGE,STRING,TDA
+3 if '$DATA(^PRCS(410,CDA,4))
QUIT
SET NODE(0)=^PRCS(410,CDA,0)
+4 SET TDA=DA
SET DA=CDA
SET X=$PIECE(^PRCS(410,CDA,4),"^",8)
DO TRANK^PRCSES
+5 SET DA=TDA
DO NOW^%DTC
SET $PIECE(^PRCS(410,CDA,4),"^",4)=X
+6 SET $PIECE(^PRCS(410,CDA,9),"^",2)=SDATE
+7 FOR I=1,8
SET $PIECE(^PRCS(410,CDA,4),"^",I)=AMT
+8 DO ERS410^PRC0G(CDA_"^A")
+9 SET MESSAGE=""
DO ENCODE^PRCSC2(CDA,DUZ,.MESSAGE)
+10 IF MESSAGE<1
WRITE !,"Contact your Site manager for an electronic signature code"
QUIT
+11 QUIT
+12 ;
LOOK ; lookup for purchase card orders
+1 if '$DATA(DA)
QUIT
+2 SET (PRCHCDNO,PRCHXXX)=$PIECE($GET(^PRC(442,DA,23)),"^",8)
+3 NEW TIMES,START,END,EN,STA,FIN,REM,ORIG,A1,A2,AA,ERROR,FLAG,VALUE,VALUE1,COUNT,TEMP,I,J,STR,XXZ
+4 SET FLAG=0
+5 DO ARR
+6 SET VALUE1=+$PIECE($GET(^PRC(442,DA,23)),"^",8)
+7 IF VALUE1=0
IF COUNT=1
SET VALUE1=$PIECE(AA(DUZ,1),"^",3)
SET FLAG=1
+8 WRITE !,"PURCHASE CARD NAME: ",$PIECE($GET(^PRC(440.5,VALUE1,0)),"^",11),$SELECT(VALUE1=0:"",1:"//")
READ XXZ:DTIME
+9 IF XXZ=""
IF VALUE1'=0
WRITE " ",$PIECE($GET(^PRC(440.5,VALUE1,0)),"^",11)
SET XXZ=FLAG
DO SET
if $GET(ERROR)=""
QUIT
GOTO LOOK
+10 IF XXZ=" "
IF VALUE1'=0
WRITE " ",$PIECE($GET(^PRC(440.5,VALUE1,0)),"^",11)
SET XXZ=FLAG
DO SET
if $GET(ERROR)=""
QUIT
GOTO LOOK
+11 ;
+12 ; Allow user to get out gracefully.
+13 IF XXZ=""
SET X=XXZ
WRITE !!,?5,"No card selected...",$CHAR(7)
QUIT
+14 IF XXZ["^"
SET X=XXZ
WRITE !!,?5,"Card selection interrupted...",$CHAR(7)
QUIT
+15 IF XXZ["?"
IF '$DATA(AA(DUZ,1))
WRITE !,"You are not a purchase card holder."
QUIT
+16 SET VALUE=""
IF XXZ["?"
Begin DoDot:1
+17 DO LOOK1
+18 IF XXZ=""!(XXZ["^")
SET VALUE=""
QUIT
+19 IF '$DATA(AA(DUZ,XXZ))
SET VALUE=""
QUIT
+20 WRITE " ",$PIECE(AA(DUZ,XXZ),"^",2)
+21 DO SET
if $GET(ERROR)'=""
SET VALUE=""
End DoDot:1
IF VALUE=""
WRITE "??"
GOTO LOOK
+22 if VALUE=1
QUIT
+23 ;
TESTL ;
+1 IF XXZ?1.6N
Begin DoDot:1
+2 DO LOOK1
+3 IF XXZ=""!(XXZ["^")
SET VALUE=""
QUIT
+4 IF '$DATA(J(XXZ))
SET VALUE=""
QUIT
+5 WRITE " ",$PIECE(AA(DUZ,XXZ),"^",2)
+6 DO SET
if $GET(ERROR)'=""
SET VALUE=""
End DoDot:1
IF VALUE=""
WRITE "??"
GOTO LOOK
+7 if VALUE=1
QUIT
+8 DO LOOK1
+9 IF VALUE'=1
WRITE " ??"
GOTO LOOK
+10 IF (XXZ["^")!(XXZ="")
WRITE " ??"
GOTO LOOK
+11 IF '$DATA(J(XXZ))
WRITE "??"
GOTO LOOK
+12 WRITE " ",$PIECE(AA(DUZ,XXZ),"^",2)
DO SET
IF $GET(ERROR)'=""
GOTO LOOK
+13 QUIT
+14 ;
SET IF XXZ=0
SET ERROR=1
QUIT
+1 SET TEMP=$PIECE(AA(DUZ,XXZ),"^",3)
+2 SET VALUE=1
+3 IF $PIECE($GET(^PRC(440.5,TEMP,2)),U,2)="Y"
WRITE ?50,"Inactive Purchase Card.",!
SET ERROR=1
SET VALUE=""
KILL TEMP
QUIT
+4 SET PRCHXXX=TEMP
+5 QUIT
+6 ;
+7 ; Prevent use of card if it is inactive, or the approving official is
+8 ; missing, or the card has expired.
ARR SET (COUNT,I)=0
FOR
SET I=$ORDER(^PRC(440.5,"C",DUZ,I))
if I=""
QUIT
Begin DoDot:1
+1 if $PIECE($GET(^PRC(440.5,I,2)),U,2)="Y"!($PIECE($GET(^PRC(440.5,I,0)),"^",9)="")
QUIT
+2 IF $PIECE(^PRC(440.5,I,2),U,4)]""
if $PIECE($GET(^PRC(440.5,I,2)),U,4)<DT
QUIT
+3 SET COUNT=COUNT+1
SET STR=$PIECE($GET(^PRC(440.5,I,0)),"^",1)
SET STR1=$PIECE($GET(^PRC(440.5,I,0)),"^",11)
+4 IF I=+$PIECE($GET(^PRC(442,DA,23)),"^",8)
SET FLAG=COUNT
+5 SET AA(DUZ,COUNT)=STR_"^"_STR1_"^"_I
End DoDot:1
+6 SET REM=COUNT#20
SET END=COUNT-REM
SET TIMES=END/20
+7 QUIT
+8 ;
LOOK1 ;
+1 KILL J
SET OUT=""
SET ORIG=XXZ
if ORIG["?"
SET ORIG=""
if TIMES=0
SET TIMES=1
+2 NEW BB,VAL,ZZ
IF ORIG'=""
SET VAL=0
FOR ZZ=1:1:COUNT
Begin DoDot:1
+3 IF $PIECE(AA(DUZ,ZZ),"^",2)[ORIG
SET VAL=VAL+1
SET BB=ZZ
End DoDot:1
+4 IF $GET(VAL)=1
SET J(BB)=1
SET VALUE=1
SET XXZ=BB
SET OUT=1
QUIT
+5 SET STA=0
FOR J=1:1:TIMES
if $GET(OUT)=1
QUIT
Begin DoDot:1
+6 SET START=1+((J-1)*20)
SET EN=J*20
if COUNT<20
SET EN=COUNT
+7 FOR I=START:1:EN
IF $PIECE(AA(DUZ,I),"^",2)[ORIG
SET J(I)=1
SET VALUE=1
WRITE !,I,?5,$PIECE(AA(DUZ,I),"^",2)
+8 FOR I=START:1:EN
IF $GET(J(I))=1
SET FIN=I
IF STA=0
SET STA=I
+9 IF $GET(VALUE)=1
WRITE !,"CHOOSE ",STA,"-",FIN,": "
READ XXZ:DTIME
IF '$TEST
SET OUT=1
+10 IF XXZ'=""
IF XXZ>COUNT
SET OUT=1
+11 IF XXZ'=""
IF XXZ'>EN
SET OUT=1
End DoDot:1
if $GET(OUT)=1
QUIT
+12 if $GET(OUT)=1
QUIT
+13 IF COUNT<20
QUIT
+14 KILL J
SET VALUE=""
FOR I=END+1:1:COUNT
IF $PIECE(AA(DUZ,I),"^",2)[ORIG
SET J(I)=1
SET VALUE=1
WRITE !,I,?5,$PIECE(AA(DUZ,I),"^",2)
+15 FOR I=END+1:1:COUNT
IF $GET(J(I))=1
SET FIN=I
+16 IF $GET(VALUE)=1
WRITE !,"CHOOSE ",STA,"-",FIN,": "
READ XXZ:DTIME
IF XXZ'=""!'$TEST
SET OUT=1
+17 QUIT
+18 ;
REF ;Stop users atempting to enter a past date and clean up the P.O. DATE
+1 ;field and its cross reference, "AB".
+2 SET PRCHX=@"^DD(442,.1,1,1,2)"
XECUTE PRCHX
KILL PRCHX
+3 SET $PIECE(^PRC(442,DA,1),"^",15)=""
+4 QUIT
