source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHEC1.m@ 1607

Last change on this file since 1607 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.9 KB
Line 
1PRCHEC1 ;SF-ISC/TKW-SUPPLEMENTAL ROUTINES CALLED FROM PRCHEC ;4/20/92 9:41 AM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5EDIT G:$D(PRCHENT) E2 G:$D(PRCHISMS) E2
6 S %A=" Do you want to generate the codesheets",%B=" Answer NO if you do not wish to build the LOG codesheets at this time.",%=1 D ^PRCFYN I %=-1 K PRCHPO Q
7 G:%=1 E2 W !!," Do you want to remove this P.O. or Receiving Report from the list of",!,"pending codesheets?"
8 S %A="REMOVE FROM LIST",%B="If you answer YES, and later want to generate codesheets, you will have",%B(1)="to use the 'Create a Codesheet' option.",%=2 D ^PRCFYN D:%=1 R K PRCHPO
9 Q
10 ;
11E2 S PRCHPONO=$P(^PRC(442,PRCHPO,0),U,1)
12 S X=$G(^PRC(442,PRCHPO,17)),Y=$G(^(18))
13 W !!,"P.O.(PAT) No.: "_PRCHPONO,!,"Document Identifier: ",$P(Y,U,3) W:PRCHN("SC")=1 ?35,"Requisition Number: ",$P(Y,U,10) W !
14 W:PRCHN("SFC")'=2&(PRCHN("SC")'=0) "Department No.: ",$P(X,U,1),! W "Source Code: "_PRCHN("SC"),!
15 Q:$D(PRCHISMS) G:PRCHTYP'="R" EDIT1
16 W !,"Payable Code: "_$P(Y,U,2),!
17 W "Reason Code: "_$P(X,U,14),!,"DEPOT (or Releasing Facility): ",$P(Y,U,1)
18 I PRCHN("SC")=1 W ?45,"Depot Voucher No.: ",$P($G(^PRC(442,PRCHPO,1)),U,13)
19 W ! I PRCHN("SFC")'=2 W $C(7),!," *** ENTER DIETETICS COST PERIOD IF THIS IS A SUBSISTANCE ORDER ***",!,?5,"**** Dietetics Cost Period: "_$P($G(^PRC(442,PRCHPO,11,PRCHRPT,1)),U,2),!! G EDIT2
20 ;
21EDIT1 G:PRCHN("SC")'=0 EDIT2
22 W !,"Document Identifier Code: "_$P(X,U,2),?38,"Routing Identifier Code: "_$P($G(^PRCD(441.4,+$P(X,U,3),0)),U,1)
23 W !,"Media & Status Code: "_$P($G(^PRCD(441.4,+$P(X,U,11),0)),U,1),?38,"Activity Address Code: "_$P(X,U,16)
24 W !,"Dept.Designation (Demand Code): "_$P($G(^PRCD(441.4,+$P(X,U,4),0)),U,1),?38,"Fund Code: "_$P(X,U,6),!,"Distribution Code: "_$P(X,U,7),?38,"Project Code: "_$P(X,U,8)
25 W !,"Priority Code: "_$P($G(^PRCD(441.4,+$P(X,U,9),0)),U,1),?38,"Advice Code: "_$P($G(^PRCD(441.4,+$P(X,U,10),0)),U,1),!!
26 ;
27EDIT2 S %A="Do you wish to pre-edit codesheet data ",%B="This data will go on every code sheet. 'NO' will cause the",%B(1)="code sheets to be built with the data as shown,",%B(2)="'^' to quit.",%=2 D YN^PRCFYN
28 K:%=-1 PRCHPO Q:%'=1 W !!! K DIE,DA,DR S DIE="^PRC(442,",DA=PRCHPO,DR=102 S:PRCHN("SC")=1 DR=DR_";102.4" S:PRCHN("SFC")'=2&(PRCHN("SC")'=0) DR=DR_";70"
29 I PRCHTYP="R" S:PRCHN("SFC")=2 DR=DR_";83//^S X=1" S:PRCHN("SC")=1 DR=DR_";107;.09" S DR=DR_";101"
30 S:PRCHTYP="A"&(PRCHN("SC")=0) DR=DR_";71;72;80;72.4;73;75;76;77;78;79"
31 D ^DIE K DIE,DA,DR I PRCHTYP="R",PRCHN("SFC")'=2 S DIE="^PRC(442,"_PRCHPO_",11,",DA(1)=PRCHPO,DA=PRCHRPT,DR=20 D ^DIE K DIE,DA,DR
32 Q:PRCHTYP'="R" Q:PRCHN("SFC")'=2 W !!!,"Select any items for which you wish to enter a source deviation code.",!
33 ;
34EDIT3 S DIC="^PRC(442,"_PRCHPO_",2,",DA(1)=PRCHPO,DIC(0)="AEQM" D ^DIC I Y>0 S DIE=DIC,DA=+Y,DR=39.5 D ^DIE G EDIT3
35 Q
36 ;
37SETUP S PRCHN("SC")="" I $D(^PRC(442,PRCHPO,1)) S PRCHN("SC")=$S($D(^PRCD(420.8,+$P(^(1),U,7),0)):$P(^(0),U,1),1:"") S:"013"[PRCHN("SC") PRCHNRQ=1
38 S PRCHN("MP")=$P($G(^PRCD(442.5,+$P(^PRC(442,PRCHPO,0),U,2),0)),U,3)
39 S PRCHN("SFC")=$P(^PRC(442,PRCHPO,0),U,19),PRCHEMG=$P($G(^(1)),U,17)
40 Q
41 ;
42OBL Q:'$P(^PRC(442,PRCHPO,0),U,12) I $D(^PRC(442,PRCHPO,18)),$P(^(18),U,12) W $C(7),!!!,"Control Point Obligated Balances have already been updated.",!! Q
43 W !! S %A=" Update Control Point Obligated Balance",%B=" Review the Order first to make sure it is correct. This step should be",%B(1)="done to make sure the Control Point Balance matches CALM."
44 S %=2 D ^PRCFYN I %'=1 K PRCHPO Q
45 D OBL^PRCHNRQ
46 Q
47 ;
48ASK ;Ask user if they want to report showing code sheets to be created
49 W !!!,$C(7),"**** Do you want to print a report showing code sheets to be created? ****" S %A="PRINT REPORT",%B="Answer 'Y' to see what orders have not yet had code sheets generated",%=2
50 D YN^PRCFYN
51 Q
52 ;
53R ;REMOVE P.O. OR RECEIVING REPORT FROM PENDING LIST
54 I PRCHTYP="A" K ^PRC(442,"AE","N",PRCHPO) Q
55 I PRCHTYP="R" K ^PRC(442,"AF","N",PRCHPO,PRCHRPT)
56 Q
Note: See TracBrowser for help on using the repository browser.