PRCHRCS7 ;SF/TKW,WISC/RWS-PRINT REPORTS SHOWING WHAT DEPOT LOG CODE SHEETS NEED TO BE GENERATED ;3-25-91/08:11
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
EN S PRCHSAVQ=PRCHQ,PRCHQ=PRCHQ_"^PRCHRCS7",PRCHQ("DEST")="S" D ^PRCHQUE
S PRCH=$S(PRCHSAVQ["EN1":"AE",PRCHSAVQ["EN2":"AF",1:"") I PRCH="" G Q2
F PRCHPO=0:0 S PRCHPO=$O(^PRC(442,PRCH,"N",PRCHPO)) Q:'PRCHPO I $D(^PRC(442,PRCHPO,0)),+^(0)=PRC("SITE"),$D(^(1)),$P(^(1),U,18)="N" W $P(^(0),U,1),! D DELE
;
Q2 K PRCH,PRCHSAVQ,PRCHQ Q
;
EN1 ;PRINT REPORT OF ACQUISITIONS CODE SHEETS TO BE DONE
S PRCHRPT=1,PRCH="AE" G RD
;
EN2 ;PRINT REPORT OF RECV.REPORT CODE SHEETS TO BE DONE
S PRCHRPT=2,PRCH="AF"
;
RD K ^TMP($J) S Y=DT D DD^%DT S PRCHDT=Y,PRCHPAGE=0 D HD
F PRCHPO=0:0 S PRCHPO=$O(^PRC(442.8,PRCH,"N",PRCHPO)) Q:'PRCHPO I $D(^PRC(442,PRCHPO,0)) S X=$P(^(0),U,1) I +X=PRC("SITE") S ^TMP($J,$P(X,"-",2))=PRCHPO I $D(^PRC(442,PRCHPO,1)),$P(^(1),U,18)="N" S $P(^TMP($J,$P(X,"-",2)),U,2)="**"
S PRCHPONO=""
F J=0:0 S PRCHPONO=$O(^TMP($J,PRCHPONO)) Q:PRCHPONO="" S PRCHPO=$P(^(PRCHPONO),U,1),PRCHNON=$P(^(PRCHPONO),U,2) D P1 I PRCHRPT=2 F PRCHFPT=0:0 S PRCHFPT=$O(^PRC(442.8,"AF","N",PRCHPO,PRCHFPT)) Q:'PRCHFPT D P2
G Q
;
P1 D:PRCHDY>60 HD
W !,?1,PRCHNON,?4,PRCHPONO D PODATA W ?15,Y,?30,PRCHMOP,?62,PRCHSFC,!,?7,PRCHVND S PRCHDY=PRCHDY+2 I PRCHRPT=1 W ! S PRCHDY=PRCHDY+1
Q
;
PODATA S X=^PRC(442,PRCHPO,0)
S PRCHMOP=$P($G(^PRCD(442.5,+$P(X,U,2),0)),U,1)
S Y=$P(^DD(442,.03,0),U,3),PRCHSFC=$P(X,U,19) I PRCHSFC F I=1:1 S X=$P(Y,";",I) Q:X="" I $P(X,":",1)=PRCHSFC S PRCHSFC=$P(X,":",2) Q
S Y=$G(^PRC(442,PRCHPO,1)),PRCHVND=$P($G(^PRC(440,+Y,0)),U,1),Y=+$P(Y,U,15) D DD^%DT
Q
;
P2 Q:'$D(^PRC(442,PRCHPO,11,PRCHFPT,0)) S Y=+^(0) D DD^%DT S PRCHRDT=Y D:PRCHDY>60 HD W ?45,$J(PRCHFPT,6),?57,PRCHRDT,! S PRCHDY=PRCHDY+1
Q
;
HD S PRCHPAGE=PRCHPAGE+1 W @IOF,$S(PRCHRPT=1:"DEPOT DUE-INS",1:"RECEIVING REPORTS")_" NEEDING LOG CODE SHEETS--STATION: ",PRC("SITE"),?67,PRCHDT,?88,"PAGE ",PRCHPAGE,!
;W ?1,"(NOTE: ** INDICATES NONEXPENDABLE ORDERS)",!
W ?4,"P.O.NO.",?15,"P.O.DATE",?30,"METHOD OF PROCESSING",?62,"SPECIAL FUND CONTROL POINT",!,?7,"VENDOR"
I PRCHRPT=2 W ?45,"PARTIAL",?57,"DATE RECEIVED"
W ! F J=0:1:(IOM-2) W "-"
W ! S PRCHDY=5
Q
;
Q W $C(13),! K X,Y,I,J,PRCH,PRCHDT,PRCHDY,PRCHFPT,PRCHMOP,PRCHNON,PRCHPAGE,PRCHPO,PRCHPONO,PRCHRDT,PRCHRPT,PRCHSFC,PRCHVND
I $D(ZTSK) D KILL^%ZTLOAD
Q
;
DELE ;DELETE NON-EXPENDABLE ORDERS FROM LIST OF ORDERS NEEDING CODE-SHEETS PROCESSED.
I PRCH="AE" S DIE="^PRC(442,",DA=PRCHPO,DR="103.5///@" D ^DIE K DIE,DA,DR Q
F PRCHFPT=0:0 S PRCHFPT=$O(^PRC(442,"AF","N",PRCHPO,PRCHFPT)) Q:'PRCHFPT S DIE="^PRC(442,"_PRCHPO_",11,",DA(1)=PRCHPO,DA=PRCHFPT,DR="19.2///@" D ^DIE K DIE,DA,DR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHRCS7 2813 printed Dec 13, 2024@02:10:08 Page 2
PRCHRCS7 ;SF/TKW,WISC/RWS-PRINT REPORTS SHOWING WHAT DEPOT LOG CODE SHEETS NEED TO BE GENERATED ;3-25-91/08:11
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
EN SET PRCHSAVQ=PRCHQ
SET PRCHQ=PRCHQ_"^PRCHRCS7"
SET PRCHQ("DEST")="S"
DO ^PRCHQUE
+1 SET PRCH=$SELECT(PRCHSAVQ["EN1":"AE",PRCHSAVQ["EN2":"AF",1:"")
IF PRCH=""
GOTO Q2
+2 FOR PRCHPO=0:0
SET PRCHPO=$ORDER(^PRC(442,PRCH,"N",PRCHPO))
if 'PRCHPO
QUIT
IF $DATA(^PRC(442,PRCHPO,0))
IF +^(0)=PRC("SITE")
IF $DATA(^(1))
IF $PIECE(^(1),U,18)="N"
WRITE $PIECE(^(0),U,1),!
DO DELE
+3 ;
Q2 KILL PRCH,PRCHSAVQ,PRCHQ
QUIT
+1 ;
EN1 ;PRINT REPORT OF ACQUISITIONS CODE SHEETS TO BE DONE
+1 SET PRCHRPT=1
SET PRCH="AE"
GOTO RD
+2 ;
EN2 ;PRINT REPORT OF RECV.REPORT CODE SHEETS TO BE DONE
+1 SET PRCHRPT=2
SET PRCH="AF"
+2 ;
RD KILL ^TMP($JOB)
SET Y=DT
DO DD^%DT
SET PRCHDT=Y
SET PRCHPAGE=0
DO HD
+1 FOR PRCHPO=0:0
SET PRCHPO=$ORDER(^PRC(442.8,PRCH,"N",PRCHPO))
if 'PRCHPO
QUIT
IF $DATA(^PRC(442,PRCHPO,0))
SET X=$PIECE(^(0),U,1)
IF +X=PRC("SITE")
SET ^TMP($JOB,$PIECE(X,"-",2))=PRCHPO
IF $DATA(^PRC(442,PRCHPO,1))
IF $PIECE(^(1),U,18)="N"
SET $PIECE(^TMP($JOB,$PIECE(X,"-",2)),U,2)="**"
+2 SET PRCHPONO=""
+3 FOR J=0:0
SET PRCHPONO=$ORDER(^TMP($JOB,PRCHPONO))
if PRCHPONO=""
QUIT
SET PRCHPO=$PIECE(^(PRCHPONO),U,1)
SET PRCHNON=$PIECE(^(PRCHPONO),U,2)
DO P1
IF PRCHRPT=2
FOR PRCHFPT=0:0
SET PRCHFPT=$ORDER(^PRC(442.8,"AF","N",PRCHPO,PRCHFPT))
if 'PRCHFPT
QUIT
DO P2
+4 GOTO Q
+5 ;
P1 if PRCHDY>60
DO HD
+1 WRITE !,?1,PRCHNON,?4,PRCHPONO
DO PODATA
WRITE ?15,Y,?30,PRCHMOP,?62,PRCHSFC,!,?7,PRCHVND
SET PRCHDY=PRCHDY+2
IF PRCHRPT=1
WRITE !
SET PRCHDY=PRCHDY+1
+2 QUIT
+3 ;
PODATA SET X=^PRC(442,PRCHPO,0)
+1 SET PRCHMOP=$PIECE($GET(^PRCD(442.5,+$PIECE(X,U,2),0)),U,1)
+2 SET Y=$PIECE(^DD(442,.03,0),U,3)
SET PRCHSFC=$PIECE(X,U,19)
IF PRCHSFC
FOR I=1:1
SET X=$PIECE(Y,";",I)
if X=""
QUIT
IF $PIECE(X,":",1)=PRCHSFC
SET PRCHSFC=$PIECE(X,":",2)
QUIT
+3 SET Y=$GET(^PRC(442,PRCHPO,1))
SET PRCHVND=$PIECE($GET(^PRC(440,+Y,0)),U,1)
SET Y=+$PIECE(Y,U,15)
DO DD^%DT
+4 QUIT
+5 ;
P2 if '$DATA(^PRC(442,PRCHPO,11,PRCHFPT,0))
QUIT
SET Y=+^(0)
DO DD^%DT
SET PRCHRDT=Y
if PRCHDY>60
DO HD
WRITE ?45,$JUSTIFY(PRCHFPT,6),?57,PRCHRDT,!
SET PRCHDY=PRCHDY+1
+1 QUIT
+2 ;
HD SET PRCHPAGE=PRCHPAGE+1
WRITE @IOF,$SELECT(PRCHRPT=1:"DEPOT DUE-INS",1:"RECEIVING REPORTS")_" NEEDING LOG CODE SHEETS--STATION: ",PRC("SITE"),?67,PRCHDT,?88,"PAGE ",PRCHPAGE,!
+1 ;W ?1,"(NOTE: ** INDICATES NONEXPENDABLE ORDERS)",!
+2 WRITE ?4,"P.O.NO.",?15,"P.O.DATE",?30,"METHOD OF PROCESSING",?62,"SPECIAL FUND CONTROL POINT",!,?7,"VENDOR"
+3 IF PRCHRPT=2
WRITE ?45,"PARTIAL",?57,"DATE RECEIVED"
+4 WRITE !
FOR J=0:1:(IOM-2)
WRITE "-"
+5 WRITE !
SET PRCHDY=5
+6 QUIT
+7 ;
Q WRITE $CHAR(13),!
KILL X,Y,I,J,PRCH,PRCHDT,PRCHDY,PRCHFPT,PRCHMOP,PRCHNON,PRCHPAGE,PRCHPO,PRCHPONO,PRCHRDT,PRCHRPT,PRCHSFC,PRCHVND
+1 IF $DATA(ZTSK)
DO KILL^%ZTLOAD
+2 QUIT
+3 ;
DELE ;DELETE NON-EXPENDABLE ORDERS FROM LIST OF ORDERS NEEDING CODE-SHEETS PROCESSED.
+1 IF PRCH="AE"
SET DIE="^PRC(442,"
SET DA=PRCHPO
SET DR="103.5///@"
DO ^DIE
KILL DIE,DA,DR
QUIT
+2 FOR PRCHFPT=0:0
SET PRCHFPT=$ORDER(^PRC(442,"AF","N",PRCHPO,PRCHFPT))
if 'PRCHFPT
QUIT
SET DIE="^PRC(442,"_PRCHPO_",11,"
SET DA(1)=PRCHPO
SET DA=PRCHFPT
SET DR="19.2///@"
DO ^DIE
KILL DIE,DA,DR
+3 QUIT
