| 1 | PRCGA ;WIRMFO/CTB/PLT - POST INIT - IFCAP PURGE ;12/23/96 2:27 PM
|
|---|
| 2 | V ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | N DA,PRC442,PRCA,PRCB,ZTSTOP,X,Y
|
|---|
| 5 | ETM S PRCA="",ZTSTOP=""
|
|---|
| 6 | S MESSAGE="UPDATING PURCHASE ORDER DATE FIELD AND XREF IN FILES 410 AND 442",ITEMS="documents"
|
|---|
| 7 | S TREC=$P(^PRCS(410,0),"^",4)+$P(^PRC(442,0),"^",4)
|
|---|
| 8 | D BEGIN^PRCGU
|
|---|
| 9 | S PRCSDA=0
|
|---|
| 10 | F D S XCOUNT=XCOUNT+COUNT D PERCENT^PRCGU Q:'PRCSDA
|
|---|
| 11 | . F COUNT=1:1:LREC S PRCSDA=$O(^PRCS(410,PRCSDA)) Q:'PRCSDA D
|
|---|
| 12 | .. D DOR(PRCSDA) I $D(KILLFLAG) K KILLFLAG QUIT
|
|---|
| 13 | .. S PRCB=$G(^PRCS(410,PRCSDA,0)) Q:$P(PRCB,"^",4)'=1
|
|---|
| 14 | .. S PRCB=$G(^PRCS(410,PRCSDA,10)),PRC442=$P(PRCB,"^",3) Q:PRC442=""
|
|---|
| 15 | .. S PRCB=$G(^PRCS(410,PRCSDA,4)) Q:$P(PRCB,"^",5)=""!($P(PRCB,"^",4)="")
|
|---|
| 16 | .. Q:$P($G(^PRC(442,PRC442,1)),"^",15)'=""
|
|---|
| 17 | .. S DA=PRC442,DIE="^PRC(442,",DR=".1////"_$P(PRCB,"^",4) D ^DIE
|
|---|
| 18 | .. QUIT
|
|---|
| 19 | . QUIT
|
|---|
| 20 | S N=0 F D S XCOUNT=XCOUNT+COUNT D PERCENT^PRCGU Q:'N
|
|---|
| 21 | . F COUNT=1:1:LREC S N=$O(^PRC(442,N)) Q:'N D
|
|---|
| 22 | . S N0=$G(^(N,0)),N1=$G(^(1))
|
|---|
| 23 | . S X=$P(N1,"^",15) I X]"",'$D(^PRC(442,"AB",X,N)) S ^PRC(442,"AB",X,N)=""
|
|---|
| 24 | . I $P(N0,"^",2)=21,X="" D 1358(N,N0,N1)
|
|---|
| 25 | . QUIT
|
|---|
| 26 | D END^PRCGU
|
|---|
| 27 | QUIT
|
|---|
| 28 | 1358(DA,DA0,DA1) ;correct 1358's without po dates in 442
|
|---|
| 29 | N OB,OK,X
|
|---|
| 30 | ;If obligation data, take date of first code sheet
|
|---|
| 31 | S OB=$O(^PRC(442,DA,10,0)) I +OB D QUIT:$D(OK)
|
|---|
| 32 | . S X=$P($G(^PRC(442,DA,10,OB,0)),"^",1) I $P(X,".",3)?6N S X="2"_$P(X,".",3) D SET QUIT
|
|---|
| 33 | . QUIT
|
|---|
| 34 | ;If no obligation data, take date of first entry in 424
|
|---|
| 35 | S OB=$O(^PRC(424,"C",DA,0)) I +OB D QUIT:$D(OK)
|
|---|
| 36 | . S X=$P($G(^PRC(424,OB,0)),"^",7) I $E(X,1,7)?7N D SET QUIT
|
|---|
| 37 | . QUIT
|
|---|
| 38 | ;If no entries in 424 take Date P.O. Assigned
|
|---|
| 39 | S X=$P($G(^PRC(442,DA,12)),"^",5) I $E(X,1,7)?7N D SET QUIT:$D(OK)
|
|---|
| 40 | QUIT
|
|---|
| 41 | SET ;Places date in P.O. Date field and sets xref
|
|---|
| 42 | S X=$E(X,1,7)
|
|---|
| 43 | S $P(DA1,"^",15)=X,^PRC(442,DA,1)=DA1,^PRC(442,"AC",X,DA)=""
|
|---|
| 44 | S OK=1 QUIT
|
|---|
| 45 | EXIT QUIT
|
|---|
| 46 | ;
|
|---|
| 47 | FILE S $P(^PRCS(410,DA,1),"^",1)=X
|
|---|
| 48 | QUIT
|
|---|
| 49 | DOR(DA) ;CLEANUP DATE OF REQUEST FIELD
|
|---|
| 50 | N X,Y
|
|---|
| 51 | F I=0,1,3,4,5,6,7 S X(I)=$G(^PRCS(410,DA,I))
|
|---|
| 52 | Q:$P(X(1),"^",1)]"" ;QUIT WHEN DATE OF REQUEST PRESENT
|
|---|
| 53 | S X=$P($P(X(4),"^",4),".",1)]"" I X]"" D FILE QUIT
|
|---|
| 54 | S X=$P($P(X(1),"^",4),".",1)]"" I X]"" D FILE QUIT
|
|---|
| 55 | S X=$P($P(X(7),"^",5),".",1)]"" I X]"" D FILE QUIT
|
|---|
| 56 | S X=$P($P(X(6),"^",2),".",1)]"" I X]"" D FILE QUIT
|
|---|
| 57 | S X=$P($P(X(4),"^",13),".",1)]"" I X]"" D FILE QUIT
|
|---|
| 58 | S X=$P($P(X(5),"^",2),".",1)]"" I X]"" D FILE QUIT
|
|---|
| 59 | S X=$P($P(X(7),"^",7),".",1)]"" I X]"" D FILE QUIT
|
|---|
| 60 | S X=$P($P(X(7),"^",10),".",1)]"" I X]"" D FILE QUIT
|
|---|
| 61 | S X=$P($P(X(4),"^",7),".",1)]"" I X]"" D FILE QUIT
|
|---|
| 62 | S X=$P($P(X(4),"^",2),".",1)]"" I X]"" D FILE QUIT
|
|---|
| 63 | S X=$P($P(X(0),"^",8),".",1)]"" I X]"" D QUIT
|
|---|
| 64 | . N Y S Y=$E(X,4,5),Y=$S("01,03,05,07,08,10,12"[Y:31,Y=2:28,1:30)
|
|---|
| 65 | . S X=$E(X,1,5)_Y D FILE QUIT
|
|---|
| 66 | I $P(X(0),"^",1)?3N1"-"2N1"-"1N1"-"3.4N1"-"4N S X=$$EOFY(X(0)) I X]"" D FILE QUIT
|
|---|
| 67 | I $P(X(0),"^",12)="E" S X=$P(DT,".") D FILE QUIT
|
|---|
| 68 | D KILL410
|
|---|
| 69 | QUIT
|
|---|
| 70 | EOFY(Y) S X="",X=$P(Y,"-",2),X=$S(X>70:"2"_X,1:"3"_X)_"0930" QUIT X
|
|---|
| 71 | KILL410 D KILL410^PRCGARP1(DA) ;WHEN NO DATES OR GARBAGE, REMOVE RECORD
|
|---|
| 72 | S KILLFLAG=""
|
|---|
| 73 | QUIT
|
|---|
