- 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 Feb 18, 2025@23:44:39 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