- PRCHRP9 ;WISC/KMB-DISPUTED PURCHASE CARD ORDERS ;8/21/96 12:09
- ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- STRT S FLAG=1 ;Buyer report.
- G EN
- START ;
- S FLAG=2 ;Official report.
- EN K ^TMP($J)
- S LABEL="START" S:$G(FLAG)=1 LABEL="STRT"
- 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^PRCHRP9",ZTSAVE("FLAG")="",ZTSAVE("PRC*")="" D ^%ZTLOAD,^%ZISC Q
- D DETAIL,^%ZISC
- D CLEAN
- Q
- ;
- CLEAN ;
- K ^TMP($J),I,ID,FLAG,LN,Z0,Z1,Z2,Z3,PO,LABEL,X,XX,F0,F1,F2,F3,F4,F23,RECDT,YY,Y,PDATE,VEND,RDATE,PC,PC0,PC1,USER,AMT,XXZ,EX,PCNAME,AA,P,TIMDATE,PRCRI,ZIP
- Q
- ;
- DETAIL ;
- S (EX,XX)="" F S XX=$O(^PRC(440.5,XX)) Q:XX="" D
- .S ZIP=$G(^PRC(440.5,XX,0)),ID=$P(ZIP,"^") S:$P(ZIP,"^",9)=DUZ AA(ID)="" S:$P(ZIP,"^",10)=DUZ AA(ID)=""
- S (EX,XX)="" F S XX=$O(^PRC(442,"F",25,XX)) Q:XX="" D
- .S F0=$G(^PRC(442,XX,0))
- .S F1=$G(^PRC(442,XX,1))
- .S F23=$G(^PRC(442,XX,23))
- .I $P(F23,"^",9)="" Q
- .I $P(F23,"^",9)="N" Q
- .I $G(FLAG)=1,$P(F1,"^",10)'=DUZ Q
- .Q:("^40^41^45^"[("^"_$P($G(^PRC(442,XX,7)),U,2)_"^"))
- .S PC1=+$P(F23,"^",8),PC0=$G(^PRC(440.5,PC1,0))
- .S PC=$P(PC0,"^") Q:+PC=0
- .Q:$P(F0,"-",1)'=PRC("SITE") ;Don't mix stations
- .S USER=$P(PC0,"^",8),USER=$P($G(^VA(200,+USER,0)),"^")
- .Q:USER=""
- .;
- .; See if the Approving Official or Alternate have anything to approve.
- .I $G(FLAG)=2 Q:'$D(AA(PC))
- .I $G(FLAG)=2 Q:$P(PC0,"^",9)'=DUZ&($P(PC0,"^",10)'=DUZ)
- .S F3=$G(^PRC(442,XX,2,1,1,1,0))
- .S F4=$G(^PRC(442,XX,4,1,0))
- .S PCNAME=$P(PC0,"^",11),PCNAME=$E(PCNAME,1,15)
- .S VEND=$P(F1,"^"),VEND=$P($G(^PRC(440,+VEND,0)),"^"),AMT=$J($P(F0,"^",15),0,2)
- .I VEND="SIMPLIFIED",$P($G(^PRC(442,XX,24)),"^",2)'="" S VEND=$P($G(^PRC(442,XX,24)),"^",2)
- .S VEND=$E(VEND,1,25)
- .S PO=$P(F0,"^")
- .S (YY,Y)=$P(F1,"^",15) D DD^%DT S PDATE=Y
- .Q:YY=""
- .S Y=$P(F23,"^",19) D DD^%DT S RECDT=$P(Y,".")
- .S ^TMP($J,USER,PC,YY,PO,0)=PCNAME_"^"_PDATE_"^"_AMT_"^"_PO_"^"_VEND_"^"_RECDT
- .S ^TMP($J,USER,PC,YY,PO,1)=$E(F3,1,45),^TMP($J,USER,PC,YY,PO,2)=$E(F4,1,99)
- ;
- WRITE ; Let's go to the printer.
- U IO S U="^"
- S X=DT D NOW^%DTC,YX^%DTC S TIMDATE=Y
- S P=1,Z0="" I $O(^TMP($J,0))="" D HEADER W !!!!,?10," **** NO RECORDS TO PRINT ****" QUIT
- S Z0="" 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
- ....W ! S LN=^TMP($J,Z0,Z1,Z2,Z3,0) W !,$P(LN,"^"),?15,$P(LN,"^",2),?30,$P(LN,"^",3),?41,$P(LN,"^",4),?54,$P(LN,"^",5)
- ....W !,$P(LN,"^",6),?20,^TMP($J,Z0,Z1,Z2,Z3,1)
- ....W !,^TMP($J,Z0,Z1,Z2,Z3,2)
- ....I (IOSL-$Y)<6 D HOLD
- .I $E(IOST,1,2)'="P-",EX'[U W !!,"Press return to continue, '^' to exit: " R XXZ:DTIME S:XXZ[U EX=U S:'$T EX=U
- Q
- ;
- HOLD G HEADER:$E(IOST,1,2)="P-"!(IO'=IO(0)) W !!,"Press return to continue, '^' to exit: " R XXZ:DTIME S:XXZ[U EX=U S:'$T EX=U D:EX'=U HEADER
- Q
- ;
- W @IOF
- W "DISPUTED PURCHASE CARD ORDERS",?40,TIMDATE,?70,"PAGE ",P
- W !,"PC NAME",?15,"P.O. DATE",?30,"$AMT",?41,"PC ORDER #",?54,"VENDOR",!,"DATE RECONCILED",?20,"DESCRIPTION",!,"COMMENTS"
- W ! F I=1:1:8 W "----------"
- W !,"BUYER: ",Z0
- S P=P+1
- QUIT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHRP9 3344 printed Feb 18, 2025@23:36:47 Page 2
- PRCHRP9 ;WISC/KMB-DISPUTED PURCHASE CARD ORDERS ;8/21/96 12:09
- +1 ;;5.1;IFCAP;;Oct 20, 2000
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- STRT ;Buyer report.
- SET FLAG=1
- +1 GOTO EN
- START ;
- +1 ;Official report.
- SET FLAG=2
- EN KILL ^TMP($JOB)
- +1 SET LABEL="START"
- if $GET(FLAG)=1
- SET LABEL="STRT"
- +2 WRITE @IOF
- SET PRCF("X")="S"
- DO ^PRCFSITE
- if '$DATA(PRC("SITE"))
- QUIT
- +3 if $GET(X)="^"
- QUIT
- +4 SET %ZIS("B")=""
- SET %ZIS="MQ"
- DO ^%ZIS
- if POP
- QUIT
- +5 IF $DATA(IO("Q"))
- SET ZTRTN="DETAIL^PRCHRP9"
- SET ZTSAVE("FLAG")=""
- SET ZTSAVE("PRC*")=""
- DO ^%ZTLOAD
- DO ^%ZISC
- QUIT
- +6 DO DETAIL
- DO ^%ZISC
- +7 DO CLEAN
- +8 QUIT
- +9 ;
- CLEAN ;
- +1 KILL ^TMP($JOB),I,ID,FLAG,LN,Z0,Z1,Z2,Z3,PO,LABEL,X,XX,F0,F1,F2,F3,F4,F23,RECDT,YY,Y,PDATE,VEND,RDATE,PC,PC0,PC1,USER,AMT,XXZ,EX,PCNAME,AA,P,TIMDATE,PRCRI,ZIP
- +2 QUIT
- +3 ;
- DETAIL ;
- +1 SET (EX,XX)=""
- FOR
- SET XX=$ORDER(^PRC(440.5,XX))
- if XX=""
- QUIT
- Begin DoDot:1
- +2 SET ZIP=$GET(^PRC(440.5,XX,0))
- SET ID=$PIECE(ZIP,"^")
- if $PIECE(ZIP,"^",9)=DUZ
- SET AA(ID)=""
- if $PIECE(ZIP,"^",10)=DUZ
- SET AA(ID)=""
- End DoDot:1
- +3 SET (EX,XX)=""
- FOR
- SET XX=$ORDER(^PRC(442,"F",25,XX))
- if XX=""
- QUIT
- Begin DoDot:1
- +4 SET F0=$GET(^PRC(442,XX,0))
- +5 SET F1=$GET(^PRC(442,XX,1))
- +6 SET F23=$GET(^PRC(442,XX,23))
- +7 IF $PIECE(F23,"^",9)=""
- QUIT
- +8 IF $PIECE(F23,"^",9)="N"
- QUIT
- +9 IF $GET(FLAG)=1
- IF $PIECE(F1,"^",10)'=DUZ
- QUIT
- +10 if ("^40^41^45^"[("^"_$PIECE($GET(^PRC(442,XX,7)),U,2)_"^"))
- QUIT
- +11 SET PC1=+$PIECE(F23,"^",8)
- SET PC0=$GET(^PRC(440.5,PC1,0))
- +12 SET PC=$PIECE(PC0,"^")
- if +PC=0
- QUIT
- +13 ;Don't mix stations
- if $PIECE(F0,"-",1)'=PRC("SITE")
- QUIT
- +14 SET USER=$PIECE(PC0,"^",8)
- SET USER=$PIECE($GET(^VA(200,+USER,0)),"^")
- +15 if USER=""
- QUIT
- +16 ;
- +17 ; See if the Approving Official or Alternate have anything to approve.
- +18 IF $GET(FLAG)=2
- if '$DATA(AA(PC))
- QUIT
- +19 IF $GET(FLAG)=2
- if $PIECE(PC0,"^",9)'=DUZ&($PIECE(PC0,"^",10)'=DUZ)
- QUIT
- +20 SET F3=$GET(^PRC(442,XX,2,1,1,1,0))
- +21 SET F4=$GET(^PRC(442,XX,4,1,0))
- +22 SET PCNAME=$PIECE(PC0,"^",11)
- SET PCNAME=$EXTRACT(PCNAME,1,15)
- +23 SET VEND=$PIECE(F1,"^")
- SET VEND=$PIECE($GET(^PRC(440,+VEND,0)),"^")
- SET AMT=$JUSTIFY($PIECE(F0,"^",15),0,2)
- +24 IF VEND="SIMPLIFIED"
- IF $PIECE($GET(^PRC(442,XX,24)),"^",2)'=""
- SET VEND=$PIECE($GET(^PRC(442,XX,24)),"^",2)
- +25 SET VEND=$EXTRACT(VEND,1,25)
- +26 SET PO=$PIECE(F0,"^")
- +27 SET (YY,Y)=$PIECE(F1,"^",15)
- DO DD^%DT
- SET PDATE=Y
- +28 if YY=""
- QUIT
- +29 SET Y=$PIECE(F23,"^",19)
- DO DD^%DT
- SET RECDT=$PIECE(Y,".")
- +30 SET ^TMP($JOB,USER,PC,YY,PO,0)=PCNAME_"^"_PDATE_"^"_AMT_"^"_PO_"^"_VEND_"^"_RECDT
- +31 SET ^TMP($JOB,USER,PC,YY,PO,1)=$EXTRACT(F3,1,45)
- SET ^TMP($JOB,USER,PC,YY,PO,2)=$EXTRACT(F4,1,99)
- End DoDot:1
- +32 ;
- WRITE ; Let's go to the printer.
- +1 USE IO
- SET U="^"
- +2 SET X=DT
- DO NOW^%DTC
- DO YX^%DTC
- SET TIMDATE=Y
- +3 SET P=1
- SET Z0=""
- IF $ORDER(^TMP($JOB,0))=""
- DO HEADER
- WRITE !!!!,?10," **** NO RECORDS TO PRINT ****"
- QUIT
- +4 SET Z0=""
- 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 WRITE !
- SET LN=^TMP($JOB,Z0,Z1,Z2,Z3,0)
- WRITE !,$PIECE(LN,"^"),?15,$PIECE(LN,"^",2),?30,$PIECE(LN,"^",3),?41,$PIECE(LN,"^",4),?54,$PIECE(LN,"^",5)
- +10 WRITE !,$PIECE(LN,"^",6),?20,^TMP($JOB,Z0,Z1,Z2,Z3,1)
- +11 WRITE !,^TMP($JOB,Z0,Z1,Z2,Z3,2)
- +12 IF (IOSL-$Y)<6
- DO HOLD
- End DoDot:4
- End DoDot:3
- End DoDot:2
- +13 IF $EXTRACT(IOST,1,2)'="P-"
- IF EX'[U
- WRITE !!,"Press return to continue, '^' to exit: "
- READ XXZ:DTIME
- if XXZ[U
- SET EX=U
- if '$TEST
- SET EX=U
- End DoDot:1
- +14 QUIT
- +15 ;
- HOLD if $EXTRACT(IOST,1,2)="P-"!(IO'=IO(0))
- GOTO HEADER
- WRITE !!,"Press return to continue, '^' to exit: "
- READ XXZ:DTIME
- if XXZ[U
- SET EX=U
- if '$TEST
- SET EX=U
- if EX'=U
- DO HEADER
- +1 QUIT
- +2 ;
- +1 WRITE @IOF
- +2 WRITE "DISPUTED PURCHASE CARD ORDERS",?40,TIMDATE,?70,"PAGE ",P
- +3 WRITE !,"PC NAME",?15,"P.O. DATE",?30,"$AMT",?41,"PC ORDER #",?54,"VENDOR",!,"DATE RECONCILED",?20,"DESCRIPTION",!,"COMMENTS"
- +4 WRITE !
- FOR I=1:1:8
- WRITE "----------"
- +5 WRITE !,"BUYER: ",Z0
- +6 SET P=P+1
- +7 QUIT
