- PRCHRPT5 ;BOISE/TKW-GENERATE LOG OF REQUESTS AND P.O.'S PRINTED. ;10-13-89/4:01 PM
- V ;;5.1;IFCAP;**25**;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- EN1 ; GENERATE LOG OF REQUESTS PRINTED IN A&MM (2237'S)
- K PRCHERR
- D ST Q:'$D(PRC("SITE")) S M1="Requests (2237's)",M2="A&MM",M5="R1" D ENTDT G:'$D(PRCHBEG) EXIT
- G SDEV^PRCHRPT8
- ;
- EN2 ; GENERATE LOG OF REQUESTS PRINTED IN FISCAL (1358'S)
- K PRCHERR
- D ST Q:'$D(PRC("SITE")) S X=$P($G(^PRC(411,+PRC("SITE"),0)),U,4) Q:X'="Y" S M1="Requests (1358's)",M2="Fiscal",M5="R2" D ENTDT G:'$D(PRCHBEG) EXIT
- G SDEV^PRCHRPT8
- ;
- EN3 ; GENERATE LOG OF PO'S PRINTED IN FISCAL
- K PRCHERR
- D ST Q:'$D(PRC("SITE")) S X=$P($G(^PRC(411,+PRC("SITE"),0)),U,4) Q:X'="Y" S M1="Purchase Orders",M2="Fiscal",M5="P1" D ENTDT G:'$D(PRCHBEG) EXIT
- G SDEV^PRCHRPT8
- ;
- EN4 ; GENERATE LOG OF PO'S PRINTED IN A&MM AFTER OBLIGATION
- K PRCHERR
- D ST Q:'$D(PRC("SITE")) S M1="Purchase Orders",M2="A&MM after Obligation",M5="P2" D ENTDT G:'$D(PRCHBEG) EXIT
- G SDEV^PRCHRPT8
- ;
- EN5 ; GENERATE LOG OF RECEIVING REPORTS PRINTED IN FISCAL
- K PRCHERR
- D ST Q:'$D(PRC("SITE")) S X=$P($G(^PRC(411,+PRC("SITE"),0)),U,4) Q:X'="Y" S M1="Receiving Reports",M2="Fiscal",M5="P3" D ENTDT G:'$D(PRCHBEG) EXIT
- G SDEV^PRCHRPT8
- ; BUILD LIST PRINTED WITHIN SPECIFIED TIMES.
- ;
- RD1 S PRCHPGM="PRCHRPT5" K PRCHREC,PRCHERR F PRCHI=0:0 S PRCHI=$O(^PRCS(410,PRCHI)) Q:'PRCHI S PRCHX=$G(^PRCS(410,PRCHI,0)) I +PRCHX=PRC("SITE") D RD11
- G PR1^PRCHRPT8
- ;
- ; SCREEN OUT PURCHASE CARD TRANSACTIONS
- RD11 Q:'$D(^PRCS(410,PRCHI,7)) S PRCHDT=$P(^(7),U,7) Q:PRCHDT<PRCHBEG!(PRCHDT>PRCHEND) Q:$P($G(^PRCS(410,PRCHI,1)),"^",2)>0 Q:M5="R1"&($P(PRCHX,U,4)'>1) Q:M5="R2"&($P(PRCHX,U,4)'=1) D ADD
- Q
- ;
- RD2 S PRCHPGM="PRCHRPT5"
- F PRCHI=0:0 S PRCHI=$O(^PRC(442,PRCHI)) Q:'PRCHI S PRCHX=$G(^(PRCHI,0)) I +PRCHX=PRC("SITE"),$D(^(12)) S X=^(12),PRCHDT="" S:M5="P1" PRCHDT=$P(X,U,3) S:M5="P2" PRCHDT=$P(X,U,1) I PRCHDT'<PRCHBEG,PRCHDT'>PRCHEND D ADD
- G PR1^PRCHRPT8
- ;
- RD3 S PRCHPGM="PRCHRPT5"
- F PRCHI=0:0 S PRCHI=$O(^PRC(442,PRCHI)) Q:'PRCHI S PRCHX=$G(^(PRCHI,0)) I $P(PRCHX,"^",2),+PRCHX=PRC("SITE"),$D(^(11,0)),$P($G(^PRCD(442.5,$P(PRCHX,"^",2),0)),"^",3)-25 D RD31
- G PR1^PRCHRPT8
- ;
- RD31 F PRCHJ=0:0 S PRCHJ=$O(^PRC(442,PRCHI,11,PRCHJ)) Q:'PRCHJ I $D(^(PRCHJ,0)) S X=^(0),PRCHDT=$P(X,U,11) I PRCHDT'<PRCHBEG,PRCHDT'>PRCHEND D ADD
- Q
- ;
- ADD ; ADD RECORD TO LOG FILE (443.5) AND SCREEN OUT PURCHASE CARD ORDERS.
- Q:$G(PRCHERR)=1
- I M5="P1" S X=+$P($G(^PRCD(442.5,+$P(^PRC(442,PRCHI,0),U,2),0)),U,3) Q:X=12!(X=25) ;DO NOT PRINT IMPREST FUNDS OR PURCHASE CARD ORDERS.
- D:'$D(PRCHREC) ADD1 Q:'$D(PRCHREC) S X=$P(PRCHX,U,1)_$S(M5="P3":"-"_PRCHJ,1:"") Q:X=""
- S DIC="^PRC(443.5,"_PRCHREC_",1,",DA(1)=PRCHREC,DIC(0)="L" D ^DIC K DIC S $P(^PRC(443.5,PRCHREC,1,+Y,0),U,2,3)=PRCHI_U_PRCHDT
- L -^PRC(443.5,PRCHREC)
- Q
- ;
- ADD1 Q:$G(PRCHERR)=1 L +^PRC(443.5,0):5 E W !!,$C(7),"Another user is editing this file, try later." S PRCHERR=1 Q
- ADD2 S X=$P(^PRC(443.5,0),U,3)+1,DIC="^PRC(443.5,",DIC(0)="L",DLAYGO=443.5 D ^DIC K DIC,DLAYGO Q:Y=-1 S:$P(Y,U,3)=1 PRCHREC=+Y I $P(Y,U,3)'=1 S $P(^(0),U,3)=$P(^PRC(443.5,0),U,3)+1 G ADD2
- L +^PRC(443.5,PRCHREC):5 G:'$T ADD2
- S $P(^PRC(443.5,PRCHREC,0),U,2,4)=M5_"^"_PRCHBEG_"^"_PRCHEND,^PRC(443.5,PRCHREC,1,0)="^443.51A^^"
- L -^PRC(443.5,0)
- Q
- ;
- ENTDT K PRCHBEG,PRCHEND W !!,"Generate listing of "_M1_" that was printed in "_M2_" between:"
- W ! S %DT="AET",%DT("A")="Beginning Date/Time: " D ^%DT K:Y=-1 %DT Q:Y=-1 S PRCHBEG=Y
- W ! S %DT("A")="Ending Date/Time: " D ^%DT G:Y=-1 ENTDT G:Y<PRCHBEG ENTDT S PRCHEND=Y
- K %DT W ! S %A=" Is This OK ",%B="",%=1 D ^PRCFYN K:%=-1 PRCHBEG,PRCHEND Q:%=-1 G:%'=1 ENTDT S Y=PRCHBEG D DD^%DT S M3=Y,Y=PRCHEND D DD^%DT S M4=Y
- Q
- ;
- EXIT K M,M1,M2,M3,M4,M5,PRCHBEG,PRCHEND,PRCHERR,PRCHPR,PRCHREC,PRCHREPR,PRCHSTAT,PRCHTX,PRCHTRX,PRCHTYP,PRCHI,PRCHI5,PRCHPDAT,PRCHDT,PRCHX,PRCHALL,PRCHQ,PRCHX5,PRCHEX,PRCHPGM,PRCHNRQ,I,X,Y,D0,DA,ZTRTN
- Q
- ;
- ST S PRCF("X")="SP" D ^PRCFSITE
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHRPT5 4059 printed Jan 18, 2025@03:11:44 Page 2
- PRCHRPT5 ;BOISE/TKW-GENERATE LOG OF REQUESTS AND P.O.'S PRINTED. ;10-13-89/4:01 PM
- V ;;5.1;IFCAP;**25**;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;
- EN1 ; GENERATE LOG OF REQUESTS PRINTED IN A&MM (2237'S)
- +1 KILL PRCHERR
- +2 DO ST
- if '$DATA(PRC("SITE"))
- QUIT
- SET M1="Requests (2237's)"
- SET M2="A&MM"
- SET M5="R1"
- DO ENTDT
- if '$DATA(PRCHBEG)
- GOTO EXIT
- +3 GOTO SDEV^PRCHRPT8
- +4 ;
- EN2 ; GENERATE LOG OF REQUESTS PRINTED IN FISCAL (1358'S)
- +1 KILL PRCHERR
- +2 DO ST
- if '$DATA(PRC("SITE"))
- QUIT
- SET X=$PIECE($GET(^PRC(411,+PRC("SITE"),0)),U,4)
- if X'="Y"
- QUIT
- SET M1="Requests (1358's)"
- SET M2="Fiscal"
- SET M5="R2"
- DO ENTDT
- if '$DATA(PRCHBEG)
- GOTO EXIT
- +3 GOTO SDEV^PRCHRPT8
- +4 ;
- EN3 ; GENERATE LOG OF PO'S PRINTED IN FISCAL
- +1 KILL PRCHERR
- +2 DO ST
- if '$DATA(PRC("SITE"))
- QUIT
- SET X=$PIECE($GET(^PRC(411,+PRC("SITE"),0)),U,4)
- if X'="Y"
- QUIT
- SET M1="Purchase Orders"
- SET M2="Fiscal"
- SET M5="P1"
- DO ENTDT
- if '$DATA(PRCHBEG)
- GOTO EXIT
- +3 GOTO SDEV^PRCHRPT8
- +4 ;
- EN4 ; GENERATE LOG OF PO'S PRINTED IN A&MM AFTER OBLIGATION
- +1 KILL PRCHERR
- +2 DO ST
- if '$DATA(PRC("SITE"))
- QUIT
- SET M1="Purchase Orders"
- SET M2="A&MM after Obligation"
- SET M5="P2"
- DO ENTDT
- if '$DATA(PRCHBEG)
- GOTO EXIT
- +3 GOTO SDEV^PRCHRPT8
- +4 ;
- EN5 ; GENERATE LOG OF RECEIVING REPORTS PRINTED IN FISCAL
- +1 KILL PRCHERR
- +2 DO ST
- if '$DATA(PRC("SITE"))
- QUIT
- SET X=$PIECE($GET(^PRC(411,+PRC("SITE"),0)),U,4)
- if X'="Y"
- QUIT
- SET M1="Receiving Reports"
- SET M2="Fiscal"
- SET M5="P3"
- DO ENTDT
- if '$DATA(PRCHBEG)
- GOTO EXIT
- +3 GOTO SDEV^PRCHRPT8
- +4 ; BUILD LIST PRINTED WITHIN SPECIFIED TIMES.
- +5 ;
- RD1 SET PRCHPGM="PRCHRPT5"
- KILL PRCHREC,PRCHERR
- FOR PRCHI=0:0
- SET PRCHI=$ORDER(^PRCS(410,PRCHI))
- if 'PRCHI
- QUIT
- SET PRCHX=$GET(^PRCS(410,PRCHI,0))
- IF +PRCHX=PRC("SITE")
- DO RD11
- +1 GOTO PR1^PRCHRPT8
- +2 ;
- +3 ; SCREEN OUT PURCHASE CARD TRANSACTIONS
- RD11 if '$DATA(^PRCS(410,PRCHI,7))
- QUIT
- SET PRCHDT=$PIECE(^(7),U,7)
- if PRCHDT<PRCHBEG!(PRCHDT>PRCHEND)
- QUIT
- if $PIECE($GET(^PRCS(410,PRCHI,1)),"^",2)>0
- QUIT
- if M5="R1"&($PIECE(PRCHX,U,4)'>1)
- QUIT
- if M5="R2"&($PIECE(PRCHX,U,4)'=1)
- QUIT
- DO ADD
- +1 QUIT
- +2 ;
- RD2 SET PRCHPGM="PRCHRPT5"
- +1 FOR PRCHI=0:0
- SET PRCHI=$ORDER(^PRC(442,PRCHI))
- if 'PRCHI
- QUIT
- SET PRCHX=$GET(^(PRCHI,0))
- IF +PRCHX=PRC("SITE")
- IF $DATA(^(12))
- SET X=^(12)
- SET PRCHDT=""
- if M5="P1"
- SET PRCHDT=$PIECE(X,U,3)
- if M5="P2"
- SET PRCHDT=$PIECE(X,U,1)
- IF PRCHDT'<PRCHBEG
- IF PRCHDT'>PRCHEND
- DO ADD
- +2 GOTO PR1^PRCHRPT8
- +3 ;
- RD3 SET PRCHPGM="PRCHRPT5"
- +1 FOR PRCHI=0:0
- SET PRCHI=$ORDER(^PRC(442,PRCHI))
- if 'PRCHI
- QUIT
- SET PRCHX=$GET(^(PRCHI,0))
- IF $PIECE(PRCHX,"^",2)
- IF +PRCHX=PRC("SITE")
- IF $DATA(^(11,0))
- IF $PIECE($GET(^PRCD(442.5,$PIECE(PRCHX,"^",2),0)),"^",3)-25
- DO RD31
- +2 GOTO PR1^PRCHRPT8
- +3 ;
- RD31 FOR PRCHJ=0:0
- SET PRCHJ=$ORDER(^PRC(442,PRCHI,11,PRCHJ))
- if 'PRCHJ
- QUIT
- IF $DATA(^(PRCHJ,0))
- SET X=^(0)
- SET PRCHDT=$PIECE(X,U,11)
- IF PRCHDT'<PRCHBEG
- IF PRCHDT'>PRCHEND
- DO ADD
- +1 QUIT
- +2 ;
- ADD ; ADD RECORD TO LOG FILE (443.5) AND SCREEN OUT PURCHASE CARD ORDERS.
- +1 if $GET(PRCHERR)=1
- QUIT
- +2 ;DO NOT PRINT IMPREST FUNDS OR PURCHASE CARD ORDERS.
- IF M5="P1"
- SET X=+$PIECE($GET(^PRCD(442.5,+$PIECE(^PRC(442,PRCHI,0),U,2),0)),U,3)
- if X=12!(X=25)
- QUIT
- +3 if '$DATA(PRCHREC)
- DO ADD1
- if '$DATA(PRCHREC)
- QUIT
- SET X=$PIECE(PRCHX,U,1)_$SELECT(M5="P3":"-"_PRCHJ,1:"")
- if X=""
- QUIT
- +4 SET DIC="^PRC(443.5,"_PRCHREC_",1,"
- SET DA(1)=PRCHREC
- SET DIC(0)="L"
- DO ^DIC
- KILL DIC
- SET $PIECE(^PRC(443.5,PRCHREC,1,+Y,0),U,2,3)=PRCHI_U_PRCHDT
- +5 LOCK -^PRC(443.5,PRCHREC)
- +6 QUIT
- +7 ;
- ADD1 if $GET(PRCHERR)=1
- QUIT
- LOCK +^PRC(443.5,0):5
- IF '$TEST
- WRITE !!,$CHAR(7),"Another user is editing this file, try later."
- SET PRCHERR=1
- QUIT
- ADD2 SET X=$PIECE(^PRC(443.5,0),U,3)+1
- SET DIC="^PRC(443.5,"
- SET DIC(0)="L"
- SET DLAYGO=443.5
- DO ^DIC
- KILL DIC,DLAYGO
- if Y=-1
- QUIT
- if $PIECE(Y,U,3)=1
- SET PRCHREC=+Y
- IF $PIECE(Y,U,3)'=1
- SET $PIECE(^(0),U,3)=$PIECE(^PRC(443.5,0),U,3)+1
- GOTO ADD2
- +1 LOCK +^PRC(443.5,PRCHREC):5
- if '$TEST
- GOTO ADD2
- +2 SET $PIECE(^PRC(443.5,PRCHREC,0),U,2,4)=M5_"^"_PRCHBEG_"^"_PRCHEND
- SET ^PRC(443.5,PRCHREC,1,0)="^443.51A^^"
- +3 LOCK -^PRC(443.5,0)
- +4 QUIT
- +5 ;
- ENTDT KILL PRCHBEG,PRCHEND
- WRITE !!,"Generate listing of "_M1_" that was printed in "_M2_" between:"
- +1 WRITE !
- SET %DT="AET"
- SET %DT("A")="Beginning Date/Time: "
- DO ^%DT
- if Y=-1
- KILL %DT
- if Y=-1
- QUIT
- SET PRCHBEG=Y
- +2 WRITE !
- SET %DT("A")="Ending Date/Time: "
- DO ^%DT
- if Y=-1
- GOTO ENTDT
- if Y<PRCHBEG
- GOTO ENTDT
- SET PRCHEND=Y
- +3 KILL %DT
- WRITE !
- SET %A=" Is This OK "
- SET %B=""
- SET %=1
- DO ^PRCFYN
- if %=-1
- KILL PRCHBEG,PRCHEND
- if %=-1
- QUIT
- if %'=1
- GOTO ENTDT
- SET Y=PRCHBEG
- DO DD^%DT
- SET M3=Y
- SET Y=PRCHEND
- DO DD^%DT
- SET M4=Y
- +4 QUIT
- +5 ;
- EXIT KILL M,M1,M2,M3,M4,M5,PRCHBEG,PRCHEND,PRCHERR,PRCHPR,PRCHREC,PRCHREPR,PRCHSTAT,PRCHTX,PRCHTRX,PRCHTYP,PRCHI,PRCHI5,PRCHPDAT,PRCHDT,PRCHX,PRCHALL,PRCHQ,PRCHX5,PRCHEX,PRCHPGM,PRCHNRQ,I,X,Y,D0,DA,ZTRTN
- +1 QUIT
- +2 ;
- ST SET PRCF("X")="SP"
- DO ^PRCFSITE
- +1 QUIT