PRCHFCY ;WISC/KMB/CR-ENTRY ACTION FOR FINAL CHARGE YES REPORT 6/09/98
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
N AA,J,ORIG,OUT,REM,STA,START,STR,STR1,TIMES,VALUE,XXZ,EN,END,FIN,I,COUNT
S XXZ="",CCHECK="####"
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"
.S COUNT=COUNT+1,STR=$P($G(^PRC(440.5,I,0)),"^",1),STR1=$P($G(^PRC(440.5,I,0)),"^",11)
.S AA(DUZ,COUNT)=STR_"^"_STR1_"^"_I
I COUNT=0 W !,"You are not a purchase card holder." QUIT
S REM=COUNT#20,END=COUNT-REM,TIMES=END/20
READ ;
S VALUE=0 R !,"Enter Purchase Card Name: ",XXZ:200
D LOOK1^PRCSPC
I XXZ="^" QUIT
I XXZ="" W !,"Invalid entry." G READ
I +XXZ<1 W !,"Invalid entry." G READ
I $G(AA(DUZ,XXZ))="" W !,"This card is not registered to you." G READ
S CCHECK=$P(AA(DUZ,XXZ),"^") W " ",$P(AA(DUZ,XXZ),"^",2)
;
QUIT
;
ASK ;ask user if they wish to print data for all purchase cards,
;inactive cards, or active cards
W !,"Please select the type of purchase cards you wish to display:",!!
S DIR(0)="S^A:Active;I:Inactive;B:Both",DIR("A")="TYPE" D ^DIR K DIR Q:Y["^"
S TYPE=Y QUIT
ASK1 ;
N SCREEN S SCREEN="I $P($G(^PRC(440.5,D0,2)),""^"",2)"
S:TYPE="B" TYPE=SCREEN_"[""""" S:TYPE="I" TYPE=SCREEN_"=""Y""" S:TYPE="A" TYPE=SCREEN_"'=""Y"""
S DIS(0)=TYPE
QUIT
;
OFFI ;get official or alternate for Unreconciled Austin Transactions
;Report
W !! S DIC(0)="AEMQ",DIC="^VA(200," D ^DIC
S ENTRY=+Y K Y,DIC QUIT
;
FIND ;find PC official or alternate for card on CC record
Q:'$D(D0)
N SET1,SET2 S (SET3,SET4)=""
S SET1=$P($G(^PRCH(440.6,D0,0)),"^",4) Q:SET1="" S SET2=$O(^PRC(440.5,"B",SET1,0))
I $P($G(^PRC(440.5,+SET2,0)),"^",9)=ENTRY D Q
.S SET3=$P($G(^PRC(440.5,+SET2,0)),"^",9),SET4=$P($G(^VA(200,SET3,0)),"^")
I $P($G(^PRC(440.5,+SET2,0)),"^",10)=ENTRY D
.S SET3=$P($G(^PRC(440.5,+SET2,0)),"^",10),SET4=$P($G(^VA(200,SET3,0)),"^")
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHFCY 1978 printed Oct 16, 2024@18:08:14 Page 2
PRCHFCY ;WISC/KMB/CR-ENTRY ACTION FOR FINAL CHARGE YES REPORT 6/09/98
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 NEW AA,J,ORIG,OUT,REM,STA,START,STR,STR1,TIMES,VALUE,XXZ,EN,END,FIN,I,COUNT
+4 SET XXZ=""
SET CCHECK="####"
+5 SET (COUNT,I)=0
FOR
SET I=$ORDER(^PRC(440.5,"C",DUZ,I))
if I=""
QUIT
Begin DoDot:1
+6 if $PIECE($GET(^PRC(440.5,I,2)),U,2)="Y"
QUIT
+7 SET COUNT=COUNT+1
SET STR=$PIECE($GET(^PRC(440.5,I,0)),"^",1)
SET STR1=$PIECE($GET(^PRC(440.5,I,0)),"^",11)
+8 SET AA(DUZ,COUNT)=STR_"^"_STR1_"^"_I
End DoDot:1
+9 IF COUNT=0
WRITE !,"You are not a purchase card holder."
QUIT
+10 SET REM=COUNT#20
SET END=COUNT-REM
SET TIMES=END/20
READ ;
+1 SET VALUE=0
READ !,"Enter Purchase Card Name: ",XXZ:200
+2 DO LOOK1^PRCSPC
+3 IF XXZ="^"
QUIT
+4 IF XXZ=""
WRITE !,"Invalid entry."
GOTO READ
+5 IF +XXZ<1
WRITE !,"Invalid entry."
GOTO READ
+6 IF $GET(AA(DUZ,XXZ))=""
WRITE !,"This card is not registered to you."
GOTO READ
+7 SET CCHECK=$PIECE(AA(DUZ,XXZ),"^")
WRITE " ",$PIECE(AA(DUZ,XXZ),"^",2)
+8 ;
+9 QUIT
+10 ;
ASK ;ask user if they wish to print data for all purchase cards,
+1 ;inactive cards, or active cards
+2 WRITE !,"Please select the type of purchase cards you wish to display:",!!
+3 SET DIR(0)="S^A:Active;I:Inactive;B:Both"
SET DIR("A")="TYPE"
DO ^DIR
KILL DIR
if Y["^"
QUIT
+4 SET TYPE=Y
QUIT
ASK1 ;
+1 NEW SCREEN
SET SCREEN="I $P($G(^PRC(440.5,D0,2)),""^"",2)"
+2 if TYPE="B"
SET TYPE=SCREEN_"["""""
if TYPE="I"
SET TYPE=SCREEN_"=""Y"""
if TYPE="A"
SET TYPE=SCREEN_"'=""Y"""
+3 SET DIS(0)=TYPE
+4 QUIT
+5 ;
OFFI ;get official or alternate for Unreconciled Austin Transactions
+1 ;Report
+2 WRITE !!
SET DIC(0)="AEMQ"
SET DIC="^VA(200,"
DO ^DIC
+3 SET ENTRY=+Y
KILL Y,DIC
QUIT
+4 ;
FIND ;find PC official or alternate for card on CC record
+1 if '$DATA(D0)
QUIT
+2 NEW SET1,SET2
SET (SET3,SET4)=""
+3 SET SET1=$PIECE($GET(^PRCH(440.6,D0,0)),"^",4)
if SET1=""
QUIT
SET SET2=$ORDER(^PRC(440.5,"B",SET1,0))
+4 IF $PIECE($GET(^PRC(440.5,+SET2,0)),"^",9)=ENTRY
Begin DoDot:1
+5 SET SET3=$PIECE($GET(^PRC(440.5,+SET2,0)),"^",9)
SET SET4=$PIECE($GET(^VA(200,SET3,0)),"^")
End DoDot:1
QUIT
+6 IF $PIECE($GET(^PRC(440.5,+SET2,0)),"^",10)=ENTRY
Begin DoDot:1
+7 SET SET3=$PIECE($GET(^PRC(440.5,+SET2,0)),"^",10)
SET SET4=$PIECE($GET(^VA(200,SET3,0)),"^")
End DoDot:1
+8 QUIT
