- PRCHRCS ;SF/TKW-PRINT REPORTS SHOWING PPM WHAT LOG CODE SHEETS NEED TO BE GENERATED ;9/12/96
- 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_"^PRCHRCS",PRCHQ("DEST")="S" D ^PRCHQUE
- W !!!,$C(7),"After checking the report, you will need to purge the NONEXPENDABLE",!,"entries from the list. Since the codesheets for NONEXPENDABLE goods have",!
- W "not yet been programmed, the stations must use either FALCON, or the",!,"KEYPUNCH A CODESHEET option to create these entries, rather than this",!,"option. Therefore, they no longer need to be on the list.",!
- S %A="Delete NONEXPENDABLE entries from list",%B="Answer YES if you do not want to see these entries on the next report",%=1 D YN^PRCFYN I %'=1 G Q2
- 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 DEL
- ;
- 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,PRCH,"N",PRCHPO)) Q:'PRCHPO D
- .I $D(^PRC(442,PRCHPO,0)) S X=$P(^(0),U,1)
- .Q:$P($G(^PRC(442,PRCHPO,0)),"^",2)=25
- .I +$G(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,"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:"ACQUISITIONS",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
- ;
- DEL ;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[HPRCHRCS 3367 printed Jan 18, 2025@03:11:19 Page 2
- PRCHRCS ;SF/TKW-PRINT REPORTS SHOWING PPM WHAT LOG CODE SHEETS NEED TO BE GENERATED ;9/12/96
- 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_"^PRCHRCS"
- SET PRCHQ("DEST")="S"
- DO ^PRCHQUE
- +1 WRITE !!!,$CHAR(7),"After checking the report, you will need to purge the NONEXPENDABLE",!,"entries from the list. Since the codesheets for NONEXPENDABLE goods have",!
- +2 WRITE "not yet been programmed, the stations must use either FALCON, or the",!,"KEYPUNCH A CODESHEET option to create these entries, rather than this",!,"option. Therefore, they no longer need to be on the list.",!
- +3 SET %A="Delete NONEXPENDABLE entries from list"
- SET %B="Answer YES if you do not want to see these entries on the next report"
- SET %=1
- DO YN^PRCFYN
- IF %'=1
- GOTO Q2
- +4 SET PRCH=$SELECT(PRCHSAVQ["EN1":"AE",PRCHSAVQ["EN2":"AF",1:"")
- IF PRCH=""
- GOTO Q2
- +5 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 DEL
- +6 ;
- 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,PRCH,"N",PRCHPO))
- if 'PRCHPO
- QUIT
- Begin DoDot:1
- +2 IF $DATA(^PRC(442,PRCHPO,0))
- SET X=$PIECE(^(0),U,1)
- +3 if $PIECE($GET(^PRC(442,PRCHPO,0)),"^",2)=25
- QUIT
- +4 IF +$GET(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)="**"
- End DoDot:1
- +5 SET PRCHPONO=""
- +6 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,"AF","N",PRCHPO,PRCHFPT))
- if 'PRCHFPT
- QUIT
- DO P2
- +7 GOTO Q
- +8 ;
- 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:"ACQUISITIONS",1:"RECEIVING REPORTS")_" NEEDING LOG CODE SHEETS--STATION: ",PRC("SITE"),?67,PRCHDT,?88,"PAGE ",PRCHPAGE,!
- +1 WRITE ?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 ;
- DEL ;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