source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSES2.m@ 767

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

initial load of WorldVistAEHR
File size: 2.0 KB
RevLine 
[613]1PRCSES2 ;SF-ISC/KSS/LJP-X-REF SET STATEMENT FOR ITEM QTY ;9/17/92 3:40 PM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q:'$D(^PRCS(410,DA(1),"IT",DA,0)) Q:'$P(^(0),U,2)
5 S E=0,E(1)="" S:'$D(^PRCS(410,DA(1),4)) ^(4)=""
6 F E(0)=1:1 S E=$O(^PRCS(410,DA(1),"IT",E)) S:E?1N.N E(1)=E(1)+($P(^(E,0),U,2)*$P(^(0),U,7)) I E'?1N.N D PR1 K E Q
7 K E Q
8PR1 S ^PRCS(410,DA(1),4)=E(1)_U_$P(^PRCS(410,DA(1),4),U,2,99),E=DA,E(2)=DA(1),X=E(1),DA=DA(1) D PR2 S DA=E,DA(1)=E(2) Q
9PR2 Q:$P(^PRCS(410,DA,4),U,3)'="" S $P(^(4),U,8)=X D TRANS^PRCSES Q
10OBL ;copy or null fields for 1358 adj in file 410
11 N A,GOFLAG
12 S A=+$G(^PRCS(410,DA,0))
13 K PRCS(2) S (PRCS(1),PRCSI,GOFLAG)=0
14 F PRCSI=0:0 S PRCS(1)=$O(^PRCS(410,"D",PRCX442,PRCS(1))) Q:PRCS(1)'>0 D I GOFLAG S PRCS(2)="" Q
15 .; additional checks added for checking FORM TYPE and FY
16 .; X1 = FY from newly created adjustment
17 .; x2 = FY from record being checked
18 .S X2=$P($P(^PRCS(410,PRCS(1),0),U),"-",2)
19 .S X2=$$YEAR^PRC0C(X2),X2=$P(X2,U)
20 .S X2=$$DATE^PRC0C(X2,"E"),X2=$P(X2,U,7)
21 .S X1=$P($P(^PRCS(410,DA,0),U),"-",2)
22 .S X1=$$YEAR^PRC0C(X1),X1=$P(X1,U)
23 .S X1=$$DATE^PRC0C(X1,"E"),X1=$P(X1,U,7)
24 .D ^%DTC
25 .I $D(^PRCS(410,PRCS(1),0)),$P(^(0),U,2)="O",+^(0)=A,$P(^(0),U,4)=1,X<1865 S GOFLAG=1
26 .Q
27 I '$D(PRCS(2)) K PRCS(1),PRCSI Q
28 I $D(^PRCS(410,PRCS(1),11)),$P(^(11),U)]"" S ^PRCS(410,DA,11)=$P(^PRCS(410,PRCS(1),11),U),^PRCS(410,"J",$P(^(11),U),DA)=""
29 I $D(^PRCS(410,PRCS(1),2)) S $P(^PRCS(410,DA,2),U)=$P(^PRCS(410,PRCS(1),2),U),^PRCS(410,"E",$E($P(^(2),U),1,30),DA)="" S:$D(^PRCS(410,PRCS(1),3)) $P(^PRCS(410,DA,3),U,4)=$P(^PRCS(410,PRCS(1),3),U,4)
30 S:$P(^PRCS(410,PRCS(1),0),U,4)=1 PRCS58=1
31 I $D(^PRCS(410,PRCS(1),3)) S $P(^PRCS(410,DA,3),U,2,3)=$P(^(3),U,2,3),^PRCS(410,"AC",$P(^(3),U,3),DA)=""
32 I $D(^PRCS(410,PRCS(1),3)),$P(^(3),U,6)]"" S $P(^PRCS(410,DA,3),U,6)=$P(^(3),U,6),^PRCS(410,"AD",$P(^(3),U,6),DA)=""
33 I $D(^PRCS(410,PRCS(1),3)),$P(^(3),U,8)]"" S $P(^PRCS(410,DA,3),U,8)=$P(^(3),U,8),^PRCS(410,"AP",$P(^(3),U,8),DA)=""
34 K PRCS(1),PRCS(2),PRCSI Q
Note: See TracBrowser for help on using the repository browser.