source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHSF1.m@ 1766

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

initial load of WorldVistAEHR

File size: 3.9 KB
Line 
1PRCHSF1 ;WISC/DJM-UPDATES OR PLACES BOCS & AMOUNTS INTO PO FILE AFTER AMENDMENT ;2/16/95 3:42 PM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;AMENDED PO
5 ;UPDATES TOTAL $ AMOUNTS
6 ;CALLED FROM 443.6 COPY ROUTINE 'PRCHAMYB'
7 Q:$P(^PRC(442,DA,7),U,1)=45 L +^PRC(442,DA):1 I '$T W !," P.O. is being edited by another person !",$C(7) Q
8 S U="^",X=^PRC(442,DA,0),PRCHS("EST")=+$P(X,U,13),PRCHS("CP")=+$P(X,U,3),PRCHS("SITE")=+X I $D(^PRC(420,PRCHS("SITE"),1,PRCHS("CP"),0)),$P(^(0),U,12) S PRCHS("SP")=$P(^(0),U,12)
9 S I=0 F S I=$O(^PRC(442,DA,2,I)) Q:I=""!(I'>0) S PRCHS=I,PRCHS("N")=^(PRCHS,0),PRCHS("N2")=$G(^(2)),PRCHS("NS")=+$P(PRCHS("N"),U,4) D L
10 S (CNT,J)=0 F S J=$O(PRCHS("A",J)) Q:J=""!(J<0) D LI2
11 S (PRCHS("TOT"),PRCHS("NET"),M,PRCHS)=0
12 S BOCSHP=$G(^PRC(442,DA,23)),PRCHS(991)=+BOCSHP_"^"_PRCHS("EST") K BOCSHP
13 F S M=$O(PRCHS(M)) Q:M=""!(M'>0) I M'=991 S PRCHS("TOT")=PRCHS("TOT")+$P(PRCHS(M),U,2)
14 S PO=PRCHPO,PRC("BBFY")=$$BBFY^PRCFFU5(PRCHPO)
15 N PARAM K PRCHMO S PARAM=PRCHS("CP")_"^"_PRC("FY")_"^"_PRCFA("BBFY")
16 S PRCHMO=$$ACC^PRC0C(PRC("SITE"),PARAM)
17 S PRCHS("G/N")=$P(PRCHMO,U,12) K PRCHMO
18 I $D(PRCHS("G/N")) D:PRCHS("G/N")="G" LABEL,NET,UPDTN D:PRCHS("G/N")="N" NET,UPDTN,LABEL
19 G ^PRCHSF2
20NET ;APPLY PROMPT PAY DISCNT ONLY TO NET FUNDS, & REFLECT NET AMT ON 0 NODE
21 D TM S PTM=0 F S PTM=$O(PRCHS(PTM)) Q:(PTM="")!(PTM'>0) I $P(PRCHS(PTM),U,2) I PTM'=991 S X=$P(PRCHS(PTM),U,2),$P(PRCHS(PTM),U,2)=(X-$J(X*PRCHS("T"),0,2)),PRCHS("NET")=PRCHS("NET")+$P(PRCHS(PTM),U,2)
22 Q
23 ;
24UPDTN ;UPDATE ZERO NODE, CHECK MESSAGE, ELECTRONIC SIGNATURE ETC.
25 S PRCHS("NET")=PRCHS("NET")+PRCHS("EST"),PRCHS("TOT")=PRCHS("TOT")+PRCHS("EST"),$P(^PRC(442,DA,0),U,6,9)="^^^"
26 S $P(^PRC(442,DA,0),U,15,16)=PRCHS("TOT")_"^"_PRCHS("NET")
27 ;NOW UPDATE THE 'AMOUNT CHANGED' FIELD
28 ;PRCHTOTQ = THE TOTAL AMOUNT OF THE PO BEFORE THIS UPDATE
29 ;PRCHTOTQ IS SET IN ROUTINE 'PRCHAMYA'
30 S PRCHS("TOTN")=PRCHS("TOT")-PRCHTOTQ,$P(^PRC(442,PRCHPO,6,PRCHAM,0),U,3)=PRCHS("TOTN"),MESSAGE=""
31 D RECODE^PRCHES6(PRCHPO,PRCHAM,.MESSAGE)
32 S MESS1=MESSAGE,MESSAGE=1
33 I $G(PRCHS("SP"))'=2,$P(^PRC(442,DA,0),U,2)'=25 D RECODE^PRCHES7(PRCHPO,PRCHAM,.MESSAGE)
34 I MESS1'=1!(MESSAGE'=1) W !,"An error has occurred while recoding an ESIG."
35 Q
36LABEL ;
37 S (CTR,I)=0 F S I=$O(PRCHS(I)) Q:I'>0 D IT
38 Q
39 ;
40IT N DA S:$D(DA(1)) PRCHDA1=DA(1) S DA(1)=PRCHPO
41 S BOC=$P(PRCHS(I),U),AMT=$P(PRCHS(I),U,2),DA=0
42IT1 ;LOOK FOR BOC
43 ;IF FOUND
44 ; 1, SEE IF FMS LINE NUMBER=991 & I FROM PRCHS(I)=991
45 ; A, IF SO, ENTER AMT AND QUIT
46 ; 2, SEE IF FMS LINE NUMBER'=991 & I '=991
47 ; A, IF SO, ENTER AMT AND QUIT
48 S DA=$O(^PRC(442,DA(1),22,"B",+BOC,DA)),FLAGOK=""
49 I DA>0 D G:FLAGOK="" IT1 Q
50 .S UPDT=$G(^PRC(442,DA(1),22,DA,0)),LINO=$P(UPDT,U,3)
51 .I LINO=991,(I=991) S $P(UPDT,U,2)=AMT,^PRC(442,DA(1),22,DA,0)=UPDT,FLAGOK=1 Q
52 .I LINO'=991,(I'=991) S $P(UPDT,U,2)=AMT,^PRC(442,DA(1),22,DA,0)=UPDT,FLAGOK=1 Q
53 .Q
54 ;IF YOU ARRIVED HERE & I=991 YOU NEED TO FIND THE IEN IN NODE 22
55 ;THAT HAS AN FMS LINE NUMBER = 991.
56 ;WHEN FOUND ENTER BOC & AMT FROM LINE IT+1 AND QUIT.
57 I I=991 D Q:FLAGOK=1
58 .S DA=0 F S DA=$O(^PRC(442,DA(1),22,DA)) Q:DA'>0 D Q:FLAGOK=1
59 ..S UPDT=$G(^PRC(442,DA(1),22,DA,0)),LINO=$P(UPDT,U,3)
60 ..I LINO=991 S $P(UPDT,U)=BOC,$P(UPDT,U,2)=AMT,^PRC(442,DA(1),22,DA,0)=UPDT,FLAGOK=1 Q
61 .Q
62 S DIC="^PRC(442,"_DA(1)_",22,",DIC(0)="L",X=+BOC K DD,DO D FILE^DICN I Y'>0 W !," ERROR " Q
63 N DA S DIE=DIC,DA=+Y
64 S LAST=LAST+1
65 S DR="1////^S X=AMT;2////^S X=LAST" D ^DIE K X,Y,DIE,DIC
66 S:$D(PRCHDA1) DA(1)=PRCHDA1 K PRCHDA1
67 Q
68 ;
69L S:'$D(PRCHS("A",PRCHS("NS"))) PRCHS("A",PRCHS("NS"))="" S LICOST=+$P(PRCHS("N2"),U,1),PRCHS("A",PRCHS("NS"))=+(PRCHS("A",PRCHS("NS")))+LICOST-$P(PRCHS("N2"),U,6)
70 Q
71 ;
72LI2 S CNT=CNT+1 S PRCHS(CNT)=J_U_PRCHS("A",J) K PRCHS("A",J)
73 Q
74 ;
75TM ;
76 S PRCHS("T")=0,I=0 F S I=$O(^PRC(442,DA,5,I)) Q:'I S X=^(I,0) I +X>0 S I(100-X)=+X
77 S:$O(I(0)) PRCHS("T")=I($O(I(0))),PRCHS("T")=PRCHS("T")/100 K I Q
78 Q
Note: See TracBrowser for help on using the repository browser.