- PRCHRP4 ;WISC/KMB/CR-PC ORDERS READY FOR APPROVAL ;06/11/98 1:50 PM
- ;;5.1;IFCAP;**25**;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- START ;
- N APO,APO1,APO2,LN,PC1,I,LN,X,XX,PO,P,PA,F1,F2,USER,XUSER,F3,YY,Y,PDATE,VEND,RDATE,PC,USER,AMT,XXZ,EX,STATUS,ID,ZIP,AA,Z0,Z1,Z2,Z3,Z4,TIMDATE
- K ^TMP($J) W @IOF
- S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE"))
- Q:$G(X)="^"
- S %ZIS("B")="",%ZIS="MQ" D ^%ZIS Q:POP
- I $D(IO("Q")) S ZTRTN="DETAIL^PRCHRP4",ZTSAVE("PRC*")="" D ^%ZTLOAD,^%ZISC Q
- D DETAIL,^%ZISC Q
- ;
- DETAIL ;
- S APO=DUZ,CNT=0
- S XUSER="" F S XUSER=$O(^PRC(442,"MAPP",XUSER)) Q:XUSER="" D
- .S XX="" F S XX=$O(^PRC(442,"MAPP",XUSER,XX)) Q:XX="" D
- ..;Keep orders from different stations separate
- ..I $D(PRC("SITE")) Q:$P(^PRC(442,XX,0),"-",1)'=PRC("SITE")
- ..S (PC,PC1)=$P($G(^PRC(442,XX,23)),"^",8),PC=$P($G(^PRC(440.5,+PC,0)),"^") S:PC="" PC=0
- ..S F1=$G(^PRC(442,XX,0)),F2=$G(^PRC(442,XX,1)),F3=$G(^PRC(442,XX,2,1,1,1,0))
- ..;Get the approving official or alternate app. official
- ..S APO1=$P($G(^PRC(440.5,+PC1,0)),"^",9)
- ..I APO1'=DUZ S APO2=$P($G(^PRC(440.5,+PC1,0)),"^",10) Q:APO2=""
- ..S APO=$S(APO1=DUZ:DUZ,APO2=DUZ:DUZ,1:"")
- ..S:APO'="" APO=$P($G(^VA(200,APO,0)),"^")
- ..S USER=$P($G(^PRC(440.5,+PC1,0)),"^",8),USER=$P($G(^VA(200,+USER,0)),"^"),VEND=$P(F2,"^"),VEND=$P($G(^PRC(440,+VEND,0)),"^"),AMT=$P(F1,"^",15),VEND=$E(VEND,1,30)
- ..I VEND="SIMPLIFIED",$P($G(^PRC(442,XX,24)),"^",2)'="" S VEND=$P($G(^PRC(442,XX,24)),"^",2)
- ..Q:USER=""!(APO="")
- ..S PO=$P(F1,"^")
- ..S Y=$P(^PRC(442,XX,23),"^",19) D DD^%DT S RDATE=Y
- ..S (YY,Y)=$P(F2,"^",15) D DD^%DT S PDATE=Y
- ..S ^TMP($J,USER,-YY,APO,PC,PO)=PDATE_"^"_RDATE_"^"_PO_"^"_AMT_"^"_VEND
- ..S ^TMP($J,USER,-YY,APO,PC,PO,1)=$E(F3,1,45),CNT=$G(CNT)+1
- ;
- WRITE ;
- U IO S U="^"
- S X=DT D NOW^%DTC,YX^%DTC S TIMDATE=Y
- I '$D(^TMP($J)) S P=1,Z0="" D HEADER W !!!!,?10,"*** NO RECORDS TO PRINT ***" Q
- S (P,EX)=1,Z0=0 F S Z0=$O(^TMP($J,Z0)) Q:EX[U Q:Z0="" D
- .D HEADER
- .S Z1="" F S Z1=$O(^TMP($J,Z0,Z1)) Q:Z1="" Q:EX[U D
- ..S Z2="" F S Z2=$O(^TMP($J,Z0,Z1,Z2)) Q:Z2="" Q:EX[U D
- ...S Z3="" F S Z3=$O(^TMP($J,Z0,Z1,Z2,Z3)) Q:Z3="" Q:EX[U D
- ....S Z4="" F S Z4=$O(^TMP($J,Z0,Z1,Z2,Z3,Z4)) Q:Z4="" Q:EX[U D
- .....I (IOSL-$Y)<6 D HOLD Q:EX[U
- .....W ! S LN=^TMP($J,Z0,Z1,Z2,Z3,Z4)
- .....W !,$P(LN,"^"),?20,$P(LN,"^",2),?37,$P(LN,"^",3),?55,$J($P(LN,"^",4),0,2)
- .....W !,$P(LN,"^",5),?35,^TMP($J,Z0,Z1,Z2,Z3,Z4,1)
- .I $E(IOST)'="P",EX'["^" W !,"Press return to continue, '^' to exit: " R XXZ:DTIME S:XXZ["^" EX="^" S:'$T EX=U
- W !!,?10,"Total number of orders found: ",CNT
- K ^TMP($J),CNT
- QUIT
- ;
- HOLD G HEADER:$E(IOST)="P"!(IO'=IO(0)) W !,"Press return to continue, '^' to exit: " R XXZ:DTIME S:XXZ["^" EX="^" S:'$T EX=U D:EX'=U HEADER Q
- ;
- W @IOF
- W !,"PURCHASE CARD ORDERS READY FOR APPROVAL",?45,TIMDATE,?70,"PAGE ",P
- W !,"PO DATE",?20,"DATE RECONCILED",?37,"PO NUMBER",?55,"$AMT",!,?8,"VENDOR",?35,"DESCRIPTION"
- W ! F I=1:1:8 W "----------"
- W !,?20,"BUYER: ",Z0
- S P=P+1
- QUIT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHRP4 3072 printed Feb 18, 2025@23:36:43 Page 2
- PRCHRP4 ;WISC/KMB/CR-PC ORDERS READY FOR APPROVAL ;06/11/98 1:50 PM
- +1 ;;5.1;IFCAP;**25**;Oct 20, 2000
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- START ;
- +1 NEW APO,APO1,APO2,LN,PC1,I,LN,X,XX,PO,P,PA,F1,F2,USER,XUSER,F3,YY,Y,PDATE,VEND,RDATE,PC,USER,AMT,XXZ,EX,STATUS,ID,ZIP,AA,Z0,Z1,Z2,Z3,Z4,TIMDATE
- +2 KILL ^TMP($JOB)
- WRITE @IOF
- +3 SET PRCF("X")="S"
- DO ^PRCFSITE
- if '$DATA(PRC("SITE"))
- QUIT
- +4 if $GET(X)="^"
- QUIT
- +5 SET %ZIS("B")=""
- SET %ZIS="MQ"
- DO ^%ZIS
- if POP
- QUIT
- +6 IF $DATA(IO("Q"))
- SET ZTRTN="DETAIL^PRCHRP4"
- SET ZTSAVE("PRC*")=""
- DO ^%ZTLOAD
- DO ^%ZISC
- QUIT
- +7 DO DETAIL
- DO ^%ZISC
- QUIT
- +8 ;
- DETAIL ;
- +1 SET APO=DUZ
- SET CNT=0
- +2 SET XUSER=""
- FOR
- SET XUSER=$ORDER(^PRC(442,"MAPP",XUSER))
- if XUSER=""
- QUIT
- Begin DoDot:1
- +3 SET XX=""
- FOR
- SET XX=$ORDER(^PRC(442,"MAPP",XUSER,XX))
- if XX=""
- QUIT
- Begin DoDot:2
- +4 ;Keep orders from different stations separate
- +5 IF $DATA(PRC("SITE"))
- if $PIECE(^PRC(442,XX,0),"-",1)'=PRC("SITE")
- QUIT
- +6 SET (PC,PC1)=$PIECE($GET(^PRC(442,XX,23)),"^",8)
- SET PC=$PIECE($GET(^PRC(440.5,+PC,0)),"^")
- if PC=""
- SET PC=0
- +7 SET F1=$GET(^PRC(442,XX,0))
- SET F2=$GET(^PRC(442,XX,1))
- SET F3=$GET(^PRC(442,XX,2,1,1,1,0))
- +8 ;Get the approving official or alternate app. official
- +9 SET APO1=$PIECE($GET(^PRC(440.5,+PC1,0)),"^",9)
- +10 IF APO1'=DUZ
- SET APO2=$PIECE($GET(^PRC(440.5,+PC1,0)),"^",10)
- if APO2=""
- QUIT
- +11 SET APO=$SELECT(APO1=DUZ:DUZ,APO2=DUZ:DUZ,1:"")
- +12 if APO'=""
- SET APO=$PIECE($GET(^VA(200,APO,0)),"^")
- +13 SET USER=$PIECE($GET(^PRC(440.5,+PC1,0)),"^",8)
- SET USER=$PIECE($GET(^VA(200,+USER,0)),"^")
- SET VEND=$PIECE(F2,"^")
- SET VEND=$PIECE($GET(^PRC(440,+VEND,0)),"^")
- SET AMT=$PIECE(F1,"^",15)
- SET VEND=$EXTRACT(VEND,1,30)
- +14 IF VEND="SIMPLIFIED"
- IF $PIECE($GET(^PRC(442,XX,24)),"^",2)'=""
- SET VEND=$PIECE($GET(^PRC(442,XX,24)),"^",2)
- +15 if USER=""!(APO="")
- QUIT
- +16 SET PO=$PIECE(F1,"^")
- +17 SET Y=$PIECE(^PRC(442,XX,23),"^",19)
- DO DD^%DT
- SET RDATE=Y
- +18 SET (YY,Y)=$PIECE(F2,"^",15)
- DO DD^%DT
- SET PDATE=Y
- +19 SET ^TMP($JOB,USER,-YY,APO,PC,PO)=PDATE_"^"_RDATE_"^"_PO_"^"_AMT_"^"_VEND
- +20 SET ^TMP($JOB,USER,-YY,APO,PC,PO,1)=$EXTRACT(F3,1,45)
- SET CNT=$GET(CNT)+1
- End DoDot:2
- End DoDot:1
- +21 ;
- WRITE ;
- +1 USE IO
- SET U="^"
- +2 SET X=DT
- DO NOW^%DTC
- DO YX^%DTC
- SET TIMDATE=Y
- +3 IF '$DATA(^TMP($JOB))
- SET P=1
- SET Z0=""
- DO HEADER
- WRITE !!!!,?10,"*** NO RECORDS TO PRINT ***"
- QUIT
- +4 SET (P,EX)=1
- SET Z0=0
- FOR
- SET Z0=$ORDER(^TMP($JOB,Z0))
- if EX[U
- QUIT
- if Z0=""
- QUIT
- Begin DoDot:1
- +5 DO HEADER
- +6 SET Z1=""
- FOR
- SET Z1=$ORDER(^TMP($JOB,Z0,Z1))
- if Z1=""
- QUIT
- if EX[U
- QUIT
- Begin DoDot:2
- +7 SET Z2=""
- FOR
- SET Z2=$ORDER(^TMP($JOB,Z0,Z1,Z2))
- if Z2=""
- QUIT
- if EX[U
- QUIT
- Begin DoDot:3
- +8 SET Z3=""
- FOR
- SET Z3=$ORDER(^TMP($JOB,Z0,Z1,Z2,Z3))
- if Z3=""
- QUIT
- if EX[U
- QUIT
- Begin DoDot:4
- +9 SET Z4=""
- FOR
- SET Z4=$ORDER(^TMP($JOB,Z0,Z1,Z2,Z3,Z4))
- if Z4=""
- QUIT
- if EX[U
- QUIT
- Begin DoDot:5
- +10 IF (IOSL-$Y)<6
- DO HOLD
- if EX[U
- QUIT
- +11 WRITE !
- SET LN=^TMP($JOB,Z0,Z1,Z2,Z3,Z4)
- +12 WRITE !,$PIECE(LN,"^"),?20,$PIECE(LN,"^",2),?37,$PIECE(LN,"^",3),?55,$JUSTIFY($PIECE(LN,"^",4),0,2)
- +13 WRITE !,$PIECE(LN,"^",5),?35,^TMP($JOB,Z0,Z1,Z2,Z3,Z4,1)
- End DoDot:5
- End DoDot:4
- End DoDot:3
- End DoDot:2
- +14 IF $EXTRACT(IOST)'="P"
- IF EX'["^"
- WRITE !,"Press return to continue, '^' to exit: "
- READ XXZ:DTIME
- if XXZ["^"
- SET EX="^"
- if '$TEST
- SET EX=U
- End DoDot:1
- +15 WRITE !!,?10,"Total number of orders found: ",CNT
- +16 KILL ^TMP($JOB),CNT
- +17 QUIT
- +18 ;
- HOLD if $EXTRACT(IOST)="P"!(IO'=IO(0))
- GOTO HEADER
- WRITE !,"Press return to continue, '^' to exit: "
- READ XXZ:DTIME
- if XXZ["^"
- SET EX="^"
- if '$TEST
- SET EX=U
- if EX'=U
- DO HEADER
- QUIT
- +1 ;
- +1 WRITE @IOF
- +2 WRITE !,"PURCHASE CARD ORDERS READY FOR APPROVAL",?45,TIMDATE,?70,"PAGE ",P
- +3 WRITE !,"PO DATE",?20,"DATE RECONCILED",?37,"PO NUMBER",?55,"$AMT",!,?8,"VENDOR",?35,"DESCRIPTION"
- +4 WRITE !
- FOR I=1:1:8
- WRITE "----------"
- +5 WRITE !,?20,"BUYER: ",Z0
- +6 SET P=P+1
- +7 QUIT