source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHPRCV.m@ 1111

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

initial load of WorldVistAEHR
File size: 5.1 KB
Line 
1PRCHPRCV ;WISC/DJM-FILE 442 CONVERSION ROUTINE ;8/30/95 1:41 PM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4LOOP N LOOP
5 S LOOP=0,COUNT=$P($G(^PRC(442,0)),U,4) I COUNT="" W:'$D(ZTQUEUED) !,"As you have nothing in file 442 for me to update I am going to quit." Q
6 I '$D(DT) D NOW^%DTC S DT=X
7 D NOW^%DTC S Y=% D DD^%DT W:'$D(ZTQUEUED) !!,"Starting conversion of file 442 on "_Y_".",!
8 S RECORD=$O(^PRC(411.3,"AD",0)) I RECORD>0 S LOOP=$O(^PRC(411.3,"AD",RECORD,0)) G:LOOP="DONE" END
9 I RECORD'>0 D
10 .S LOOKUP=$P($G(^PRC(411.3,0)),U,3) F S LOOKUP=LOOKUP+1 Q:$G(^PRC(411.3,LOOKUP,0))=""
11 .K DD,DO S X=LOOKUP,DLAYGO=411.3,DIC="^PRC(411.3,",DIC(0)="L" D FILE^DICN Q:+Y'>0 S $P(^PRC(411.3,+Y,0),U,11)=0,^PRC(411.3,"AD",+Y,0)=""
12 .S RECORD=+Y
13 D:'$D(ZTQUEUED) SETUP^PRCHRCV(COUNT)
14 S INIT=+$P($G(^PRC(411.3,RECORD,0)),U,12)
15 D:'$D(ZTQUEUED) UPDATE^PRCHRCV(INIT)
16 N AA,DA,DIC,DIE,DR,AMT1,AMT2,BOC1,BOC2,BOC31,LIN1,LIN2,N0,N1,N7,STAT,STAT1,F1,FY,CTR,EST,ESTA,ESTB,PRCA,SETBOC,SFCP,SFBOC,%,%H,X,ESTAA,LOOP1,LOOPB
17 S AA=0 F S LOOP=$O(^PRC(442,LOOP)) G:LOOP'>0 END D D UPDATE D:'$D(ZTQUEUED) UPDATE^PRCHRCV(0)
18 .S N0=$G(^PRC(442,LOOP,0)),N1=$G(^PRC(442,LOOP,1))
19 .S:$P(N0,U,6)=2699 $P(N0,U,6)=3131,AA=1
20 .S:$P(N0,U,8)=2699 $P(N0,U,8)=3131,AA=1
21 .I AA=1 S ^PRC(442,LOOP,0)=N0 D S AA=0
22 ..S BOC31=$P($G(^PRCD(420.2,3131,0)),U),LOOP1=0
23 ..F S LOOP1=$O(^PRC(442,LOOP,2,LOOP1)) Q:LOOP1'>0 S LOOPB=$G(^PRC(442,LOOP,2,LOOP1,0)) D
24 ...I +$P(LOOPB,U,4)=2699 K DD,DO S DA(1)=LOOP,DIE="^PRC(442,"_DA(1)_",2,",DA=LOOP1,DR="3.5////^S X=BOC31" D ^DIE
25 .S FY=$P(N1,U,15) I FY]"" S ^PRC(442,"AB",FY,LOOP)=""
26 .I FY="" D DATE(LOOP,N0,.N1) S FY=$P(N1,U,15)
27 .S FY=$E(FY,2,3)+$E(FY,4)
28 .S P2237=$P(N0,U,12) I P2237>0 S RFY=$P($P($G(^PRCS(410,P2237,0)),U),"-",2) S:RFY]"" FY=RFY K RFY
29 .S FY=$$BBFY(+N0,FY,+$P(N0,U,3))
30 .S SFCP=$P(N0,U,19) I SFCP=1!(SFCP=2) S FY=1994
31 .S DIE="^PRC(442,",DA=LOOP,DR="26///^S X=FY" D ^DIE
32 .S N7=$G(^PRC(442,LOOP,7)),(STAT,STAT1)=$P(N7,U),STAT="/"_STAT_"/",F1=""
33 .I "/6/7/10/15/20/25/26/30/31/35/36/40/42/43/45/71/81/82/"[STAT D Q:F1=1
34 ..S EST=$P(N0,U,13)
35 ..I SFCP>0,EST>0 S SFBOC=$S(SFCP=1:2220,SFCP=2:2299,1:9999) D SETBOC(SFBOC)
36 ..I SFCP=1!(SFCP=2) D EN^PRCUFC0(LOOP,SFCP,STAT1,N0,N1) S F1=1 Q
37 ..I SFCP=3 D ROOLUP S F1=1 Q
38 ..I SFCP'>0,EST>0 S AOBOC=2220 D SETBOC(AOBOC)
39 ..K ^PRC(442,LOOP,22) S ^PRC(442,LOOP,22,0)="^"_$P(^DD(442,41,0),U,2)
40 ..I $D(N0) D
41 ...S BOC1=+$P(N0,U,6),AMT1=+$P(N0,U,7),BOC2=+$P(N0,U,8),AMT2=$P(N0,U,9)
42 ...S (ESTAA,ESTA)=+$P(N0,U,13),LIN=991,ESTB=+$P($G(^PRC(442,LOOP,23)),U)
43 ...S:BOC2>0 ESTA=ESTA/2,ESTA=ESTA*100+.5\1/100
44 ...S AMT1=AMT1-ESTA
45 ...S:BOC2>0 AMT2=AMT2-ESTA
46 ...I BOC2=0 S LIN1=1 G ENTER
47 ...I BOC1'>BOC2 S LIN1=1,LIN2=2
48 ...I BOC2<BOC1 S LIN2=1,LIN1=2
49ENTER ...S (DA(1),PRCDA)=DA
50 ...K DD,DO S (DIC,PRCA)="^PRC(442,"_DA(1)_",22,",DIC(0)="L",X=BOC1 D FILE^DICN I Y>0 D
51 ....S DIE=DIC,DA=+Y,DR="1////^S X=AMT1;2////^S X=LIN1" D ^DIE
52 ...I BOC2>0 K DD,DO S DIC=PRCA,DIC(0)="L",X=BOC2 D FILE^DICN I Y>0 D
53 ....S DIE=DIC,DA=+Y,DR="1////^S X=AMT2;2////^S X=LIN2" D ^DIE
54 ...K DD,DO S DIC=PRCA,DIC(0)="L",X=ESTB D FILE^DICN I Y>0 D
55 ....S DIE=DIC,DA=+Y,DR="1////^S X=ESTAA;2////^S X=LIN" D ^DIE
56EXIT ;
57 D MM442^PRC5B
58 I '$D(ZTQUEUED) D NOW^%DTC S Y=% D DD^%DT W !!,"Ending conversion of file 442 on "_Y_".",!
59 Q
60 ;
61DATE(DA,N0,N1) ;
62 K OK D 1358(DA) Q:$D(OK)
63 D ASSIGNED(DA,.N1) Q
64 ;
651358(DA) ;
66 N OB,OK,X,DATE K OK
67 ;If obligation data, take date of first code sheet.
68 S OB=$O(^PRC(442,DA,10,0)) I +OB D Q:$D(OK)
69 .S X=$P($G(^PRC(442,DA,10,OB,0)),U,6) I $E(X,1,7)?7N D SET Q
70 .Q
71 Q
72 ;
73ASSIGNED(DA,N1) ;
74 S X=$P($G(^PRC(442,DA,12)),U,5),X=$P(X,".") I X?7N D SET Q:$D(OK)
75 S X=DT D SET
76 Q
77 ;
78SET ;
79 S DATE=$E(X,1,7)
80 S $P(N1,U,15)=DATE,DIE="^PRC(442,",DR=".1////^S X=DATE" D ^DIE
81 S OK=1 Q
82 ;
83SETBOC(BOC) ;
84 S BOC=$P($G(^PRCD(420.2,BOC,0)),U)
85 S DIE="^PRC(442,",DR="13.05////^S X=BOC" D ^DIE
86 Q
87 ;
88UPDATE ;
89 S DIE="^PRC(411.3,",DA=$O(^PRC(411.3,"AD",0)),DR="10///^S X=LOOP"
90 D ^DIE
91 Q
92 ;
93END ;
94 I LOOP'="DONE" S LOOP="DONE" D UPDATE
95 S $P(PRCSTAR,"*",80)="*"
96 W:'$D(ZTQUEUED) !,PRCSTAR
97 W:'$D(ZTQUEUED) !,"*** The PROCUREMENT & ACCOUNTING TRANSACTIONS file conversion is done. ***"
98 W:'$D(ZTQUEUED) !,PRCSTAR
99 G EXIT
100 ;
101ROOLUP ;
102 S $P(N0,U,5)=290000,^PRC(442,LOOP,0)=N0
103 S LOOP1=0,BOC=$P(^PRCD(420.2,9999,0),U)
104 F S LOOP1=$O(^PRC(442,LOOP,2,LOOP1)) Q:LOOP1'>0 D
105 .S $P(^PRC(442,LOOP,2,LOOP1,0),U,4)=BOC
106 .S ^PRC(442,LOOP,2,"D",+BOC,LOOP1)=""
107 .S ^PRC(442,LOOP,2,"AH",+BOC,$P(^PRC(442,LOOP,2,LOOP1,0),U),LOOP1)=""
108 .Q
109 N DA S (DA,PRCHPO)=LOOP
110 S DATE=$$DATE^PRC0C($P(N1,U,15),"I")
111 S PRC("FY")=$E($P(DATE,U),3,4)
112 S PRC("QTR")=$P(DATE,U,2)
113 S PRC("SITE")=+$P(N0,U)
114 S FCP=+$P(N0,U,3) I FCP]"" S PRC("CP")=+FCP
115 I '$D(PRC("PER")) D DUZ^PRCFSITE
116 D ^PRCHSF
117 Q
118 ;
119BBFY(A,B,C) ;
120 N D,E,F,X,Y
121 K PRC("BBFY")
122 S B=+$$YEAR^PRC0C(B)
123 S D=$$APP^PRC0C(A,$E(B,3,4),C)
124 S F=$$SFCP^PRC0D(A,C) I F=1!(F=2) S PRC("BBFY")=$S($P(D,"^",2)]"":$$FIRST^PRC0B1("^PRCD(420.14,""UNQ"","""_$P(D,"^",2)_""",",1993),1:"") QUIT PRC("BBFY")
125 I $P(D,"^")'["_/_" S PRC("BBFY")=B QUIT PRC("BBFY")
126 S F=$$BBFY^PRCHPRC1(A,C,1),Y=$P(F,"~",4)
127 S:Y?2.4N Y=+$$YEAR^PRC0C(Y) S PRC("BBFY")=$S(Y?4N:Y,1:"")
128 QUIT PRC("BBFY")
Note: See TracBrowser for help on using the repository browser.