PRCHRP3 ;WISC/KMB/CR SUMMARY OF UNPAID PURCHASE CARDS ;7/15/98 8:43 AM
;;5.1;IFCAP;**8,131,149**;Oct 20, 2000;Build 5
;Per VHA Directive 2004-038, this routine should not be modified.
UNPAID ; create summary report of unpaid purchase card orders
N P,PRC,ARR,XXZ,EX,I,CP,HDATE,ZP,TOT,AMT,ZTR,ZTR0,ZTR1,NOTASK
;PRC*5.3*149 insures NOTASK is set for tasked job to avoid undefined
S NOTASK=0
S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE")) Q:$G(X)="^"
W !,"Please select a device for display/print of this report.",!
S %ZIS("B")="",%ZIS="MQ" D ^%ZIS Q:POP
I $D(IO("Q")) S ZTRTN="REPORT^PRCHRP3",ZTSAVE("*")="" D ^%ZTLOAD,^%ZISC QUIT
S NOTASK=1 W !,"COMPILING."
D REPORT,^%ZISC QUIT
;
REPORT ;
K ^TMP($J) S (EX,P)=1
F I=24,29,32,34,37,38,40,41,45,50,51 S ARR(I)=""
S ZP="" F I=1:1 S ZP=$O(^PRC(442,"F",25,ZP)) Q:ZP="" W:NOTASK=1&(I#5000=0) "." D
.S ZTR0=$G(^PRC(442,ZP,0))
.I $D(PRC("SITE")) Q:$P(ZTR0,"-")'=PRC("SITE")
.S ZTR1=+$P($G(^PRC(442,ZP,7)),"^") Q:ZTR1=""
.S ZTR1=$P($G(^PRCD(442.3,ZTR1,0)),"^",2) Q:$D(ARR(ZTR1))
.S AMT=$P($G(^PRC(442,ZP,0)),"^",15)
.S CP=$P($G(^PRC(442,ZP,0)),"^",3),CP=+$P(CP," ")
.Q:CP=0
.S:'$D(^TMP($J,CP)) ^TMP($J,CP)=0 S ^TMP($J,CP)=^TMP($J,CP)+AMT
I '$D(^TMP($J)) S P=1 D HEADER1 W !!!!,?10,"*** NO RECORDS TO PRINT ***" Q
S CP="" F S CP=$O(^TMP($J,CP)) Q:CP="" Q:EX="^" D
.D:P=1 HEADER1
.W !,"CONTROL POINT: ",CP,?40,"TOTAL: $",$J(^TMP($J,CP),0,2)
.I (IOSL-$Y)<6 D HOLD1 Q:EX["^"
QUIT
;
HOLD1 G HEADER1:$E(IOST)="P"!(IO'=IO(0)) W !,"Press return to continue, '^' to exit: " R XXZ:DTIME S:XXZ="^" EX="^" S:'$T EX="^" D:EX'="^" HEADER1 Q
;
W @IOF
D NOW^%DTC S Y=$P(%,".") D DD^%DT S HDATE=Y
W !,"UNPAID PURCHASE CARD TRANSACTION BY FCP - SUMMARY",?55,HDATE,?70,"PAGE ",P
W:$D(PRC("SITE")) !,?15,"STATION #: "_PRC("SITE")
W ! F I=1:1:8 W "----------"
S P=P+1
QUIT
;
CANDEL ;cancel delivery card transaction
N FLG S FLG=1
CAN ;cancel purchase card transaction
N I,TMP1,CREF,CPREF,LABEL,KDA,ZIP,DA,KX,KY D ST^PRCHE Q:'$D(PRC("SITE"))
S DIC("A")="P.O./REQ. NO.: ",DIC(0)="AEMQZ",D="C",DIC("S")="I $P(^(0),""^"",2)=25,$P(^(12),""^"",2)="""",$P(^(7),""^"")<80,$P(^(7),""^"")'=45",DIC="^PRC(442,"
I $G(FLG)=1 S DIC("S")="I $P(^(0),""^"",2)=1,$P(^(12),""^"",2)="""",$P(^(7),""^"")<80"
W !! D IX^DIC K DIC Q:+Y<0 S (DA,KDA)=+Y
S LABEL="CAN" S:$G(FLG)=1 LABEL="CANDEL" S CPREF=$P($G(^PRC(442,KDA,0)),"^",3),CPREF=+$P(CPREF," "),ZIP=$O(^PRC(420,"A",DUZ,PRC("SITE"),CPREF,0))
I ZIP="" W !,"You are not a user for this transaction's control point." G @LABEL
D START^PRCH410
S TMP1=$P(^PRC(442,KDA,0),"^",15)
S X=$O(^PRCD(442.3,"C",45,0)),$P(^PRC(442,KDA,0),"^",15,16)="0^0" K ^(9) S (KX,KY)=45,DA=KDA
Q:$G(^PRCD(442.3,KY,0))=""
L +^PRC(442,KDA):5 E W !!,$C(7),?8,"Another user is editing this entry, try later." K KDA Q
S X=Y,DIE="^PRC(442,",DR=".5////"_KY D ^DIE L -^PRC(442,KDA) K DIE,DR,X,Y,DA,DIC
L +^PRCS(410,CCDA):5 E W !!,$C(7),?8,"Another user is editing this entry, try later." K CCDA Q
S DIE="^PRCS(410,",DA=CCDA,DR="20///^S X=TMP1"_";"_"27///^S X=TMP1"_";"_"451////^S X=""""" D ^DIE
S $P(^PRCS(410,CCDA,10),U,3)="",$P(^PRCS(410,CCDA,1),U,2)="" I $P($G(^PRCS(410,CCDA,4)),U,5)'="" K ^PRCS(410,"D",$P(^PRCS(410,CCDA,4),U,5),CCDA)
S $P(^PRCS(410,CCDA,4),U,5)=""
I $D(^PRC(442,KDA,4,0)) S CCNUM=$P($G(^(0)),"^",4) D
.Q:CCNUM="" F I=1:1:CCNUM S ^PRCS(410,CCDA,"RM",I,0)=^PRC(442,KDA,4,I,0)
.S ^PRCS(410,CCDA,"RM",0)="^442.04^"_CCNUM_"^"_CCNUM
S CREF=$P($G(^PRCS(410,CCDA,0)),"^") W !!,"Use transaction ",CREF," to access this record",!,"from your fund control point." H 3
W !!,$C(7),"Conversion completed." L -^PRCS(410,CCDA) K CCNUM,CCDA,DA
QUIT
;
R1 S FLG=1
R2 S:$G(FLG)'=1 FLG=2
R3 K FLAG D START^PRCHRP5 K FLG,FLAG QUIT
UR1 S FLG=1
UR2 S:$G(FLG)'=1 FLG=2
UR3 K FLAG D START1^PRCHRP5 K FLG,FLAG QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHRP3 3885 printed Jan 18, 2025@03:11:30 Page 2
PRCHRP3 ;WISC/KMB/CR SUMMARY OF UNPAID PURCHASE CARDS ;7/15/98 8:43 AM
+1 ;;5.1;IFCAP;**8,131,149**;Oct 20, 2000;Build 5
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
UNPAID ; create summary report of unpaid purchase card orders
+1 NEW P,PRC,ARR,XXZ,EX,I,CP,HDATE,ZP,TOT,AMT,ZTR,ZTR0,ZTR1,NOTASK
+2 ;PRC*5.3*149 insures NOTASK is set for tasked job to avoid undefined
+3 SET NOTASK=0
+4 SET PRCF("X")="S"
DO ^PRCFSITE
if '$DATA(PRC("SITE"))
QUIT
if $GET(X)="^"
QUIT
+5 WRITE !,"Please select a device for display/print of this report.",!
+6 SET %ZIS("B")=""
SET %ZIS="MQ"
DO ^%ZIS
if POP
QUIT
+7 IF $DATA(IO("Q"))
SET ZTRTN="REPORT^PRCHRP3"
SET ZTSAVE("*")=""
DO ^%ZTLOAD
DO ^%ZISC
QUIT
+8 SET NOTASK=1
WRITE !,"COMPILING."
+9 DO REPORT
DO ^%ZISC
QUIT
+10 ;
REPORT ;
+1 KILL ^TMP($JOB)
SET (EX,P)=1
+2 FOR I=24,29,32,34,37,38,40,41,45,50,51
SET ARR(I)=""
+3 SET ZP=""
FOR I=1:1
SET ZP=$ORDER(^PRC(442,"F",25,ZP))
if ZP=""
QUIT
if NOTASK=1&(I#5000=0)
WRITE "."
Begin DoDot:1
+4 SET ZTR0=$GET(^PRC(442,ZP,0))
+5 IF $DATA(PRC("SITE"))
if $PIECE(ZTR0,"-")'=PRC("SITE")
QUIT
+6 SET ZTR1=+$PIECE($GET(^PRC(442,ZP,7)),"^")
if ZTR1=""
QUIT
+7 SET ZTR1=$PIECE($GET(^PRCD(442.3,ZTR1,0)),"^",2)
if $DATA(ARR(ZTR1))
QUIT
+8 SET AMT=$PIECE($GET(^PRC(442,ZP,0)),"^",15)
+9 SET CP=$PIECE($GET(^PRC(442,ZP,0)),"^",3)
SET CP=+$PIECE(CP," ")
+10 if CP=0
QUIT
+11 if '$DATA(^TMP($JOB,CP))
SET ^TMP($JOB,CP)=0
SET ^TMP($JOB,CP)=^TMP($JOB,CP)+AMT
End DoDot:1
+12 IF '$DATA(^TMP($JOB))
SET P=1
DO HEADER1
WRITE !!!!,?10,"*** NO RECORDS TO PRINT ***"
QUIT
+13 SET CP=""
FOR
SET CP=$ORDER(^TMP($JOB,CP))
if CP=""
QUIT
if EX="^"
QUIT
Begin DoDot:1
+14 if P=1
DO HEADER1
+15 WRITE !,"CONTROL POINT: ",CP,?40,"TOTAL: $",$JUSTIFY(^TMP($JOB,CP),0,2)
+16 IF (IOSL-$Y)<6
DO HOLD1
if EX["^"
QUIT
End DoDot:1
+17 QUIT
+18 ;
HOLD1 if $EXTRACT(IOST)="P"!(IO'=IO(0))
GOTO HEADER1
WRITE !,"Press return to continue, '^' to exit: "
READ XXZ:DTIME
if XXZ="^"
SET EX="^"
if '$TEST
SET EX="^"
if EX'="^"
DO HEADER1
QUIT
+1 ;
+1 WRITE @IOF
+2 DO NOW^%DTC
SET Y=$PIECE(%,".")
DO DD^%DT
SET HDATE=Y
+3 WRITE !,"UNPAID PURCHASE CARD TRANSACTION BY FCP - SUMMARY",?55,HDATE,?70,"PAGE ",P
+4 if $DATA(PRC("SITE"))
WRITE !,?15,"STATION #: "_PRC("SITE")
+5 WRITE !
FOR I=1:1:8
WRITE "----------"
+6 SET P=P+1
+7 QUIT
+8 ;
CANDEL ;cancel delivery card transaction
+1 NEW FLG
SET FLG=1
CAN ;cancel purchase card transaction
+1 NEW I,TMP1,CREF,CPREF,LABEL,KDA,ZIP,DA,KX,KY
DO ST^PRCHE
if '$DATA(PRC("SITE"))
QUIT
+2 SET DIC("A")="P.O./REQ. NO.: "
SET DIC(0)="AEMQZ"
SET D="C"
SET DIC("S")="I $P(^(0),""^"",2)=25,$P(^(12),""^"",2)="""",$P(^(7),""^"")<80,$P(^(7),""^"")'=45"
SET DIC="^PRC(442,"
+3 IF $GET(FLG)=1
SET DIC("S")="I $P(^(0),""^"",2)=1,$P(^(12),""^"",2)="""",$P(^(7),""^"")<80"
+4 WRITE !!
DO IX^DIC
KILL DIC
if +Y<0
QUIT
SET (DA,KDA)=+Y
+5 SET LABEL="CAN"
if $GET(FLG)=1
SET LABEL="CANDEL"
SET CPREF=$PIECE($GET(^PRC(442,KDA,0)),"^",3)
SET CPREF=+$PIECE(CPREF," ")
SET ZIP=$ORDER(^PRC(420,"A",DUZ,PRC("SITE"),CPREF,0))
+6 IF ZIP=""
WRITE !,"You are not a user for this transaction's control point."
GOTO @LABEL
+7 DO START^PRCH410
+8 SET TMP1=$PIECE(^PRC(442,KDA,0),"^",15)
+9 SET X=$ORDER(^PRCD(442.3,"C",45,0))
SET $PIECE(^PRC(442,KDA,0),"^",15,16)="0^0"
KILL ^(9)
SET (KX,KY)=45
SET DA=KDA
+10 if $GET(^PRCD(442.3,KY,0))=""
QUIT
+11 LOCK +^PRC(442,KDA):5
IF '$TEST
WRITE !!,$CHAR(7),?8,"Another user is editing this entry, try later."
KILL KDA
QUIT
+12 SET X=Y
SET DIE="^PRC(442,"
SET DR=".5////"_KY
DO ^DIE
LOCK -^PRC(442,KDA)
KILL DIE,DR,X,Y,DA,DIC
+13 LOCK +^PRCS(410,CCDA):5
IF '$TEST
WRITE !!,$CHAR(7),?8,"Another user is editing this entry, try later."
KILL CCDA
QUIT
+14 SET DIE="^PRCS(410,"
SET DA=CCDA
SET DR="20///^S X=TMP1"_";"_"27///^S X=TMP1"_";"_"451////^S X="""""
DO ^DIE
+15 SET $PIECE(^PRCS(410,CCDA,10),U,3)=""
SET $PIECE(^PRCS(410,CCDA,1),U,2)=""
IF $PIECE($GET(^PRCS(410,CCDA,4)),U,5)'=""
KILL ^PRCS(410,"D",$PIECE(^PRCS(410,CCDA,4),U,5),CCDA)
+16 SET $PIECE(^PRCS(410,CCDA,4),U,5)=""
+17 IF $DATA(^PRC(442,KDA,4,0))
SET CCNUM=$PIECE($GET(^(0)),"^",4)
Begin DoDot:1
+18 if CCNUM=""
QUIT
FOR I=1:1:CCNUM
SET ^PRCS(410,CCDA,"RM",I,0)=^PRC(442,KDA,4,I,0)
+19 SET ^PRCS(410,CCDA,"RM",0)="^442.04^"_CCNUM_"^"_CCNUM
End DoDot:1
+20 SET CREF=$PIECE($GET(^PRCS(410,CCDA,0)),"^")
WRITE !!,"Use transaction ",CREF," to access this record",!,"from your fund control point."
HANG 3
+21 WRITE !!,$CHAR(7),"Conversion completed."
LOCK -^PRCS(410,CCDA)
KILL CCNUM,CCDA,DA
+22 QUIT
+23 ;
R1 SET FLG=1
R2 if $GET(FLG)'=1
SET FLG=2
R3 KILL FLAG
DO START^PRCHRP5
KILL FLG,FLAG
QUIT
UR1 SET FLG=1
UR2 if $GET(FLG)'=1
SET FLG=2
UR3 KILL FLAG
DO START1^PRCHRP5
KILL FLG,FLAG
QUIT
