- PRCGA ;WIRMFO/CTB/PLT - POST INIT - IFCAP PURGE ;12/23/96 2:27 PM
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- N DA,PRC442,PRCA,PRCB,ZTSTOP,X,Y
- ETM S PRCA="",ZTSTOP=""
- S MESSAGE="UPDATING PURCHASE ORDER DATE FIELD AND XREF IN FILES 410 AND 442",ITEMS="documents"
- S TREC=$P(^PRCS(410,0),"^",4)+$P(^PRC(442,0),"^",4)
- D BEGIN^PRCGU
- S PRCSDA=0
- F D S XCOUNT=XCOUNT+COUNT D PERCENT^PRCGU Q:'PRCSDA
- . F COUNT=1:1:LREC S PRCSDA=$O(^PRCS(410,PRCSDA)) Q:'PRCSDA D
- .. D DOR(PRCSDA) I $D(KILLFLAG) K KILLFLAG QUIT
- .. S PRCB=$G(^PRCS(410,PRCSDA,0)) Q:$P(PRCB,"^",4)'=1
- .. S PRCB=$G(^PRCS(410,PRCSDA,10)),PRC442=$P(PRCB,"^",3) Q:PRC442=""
- .. S PRCB=$G(^PRCS(410,PRCSDA,4)) Q:$P(PRCB,"^",5)=""!($P(PRCB,"^",4)="")
- .. Q:$P($G(^PRC(442,PRC442,1)),"^",15)'=""
- .. S DA=PRC442,DIE="^PRC(442,",DR=".1////"_$P(PRCB,"^",4) D ^DIE
- .. QUIT
- . QUIT
- S N=0 F D S XCOUNT=XCOUNT+COUNT D PERCENT^PRCGU Q:'N
- . F COUNT=1:1:LREC S N=$O(^PRC(442,N)) Q:'N D
- . S N0=$G(^(N,0)),N1=$G(^(1))
- . S X=$P(N1,"^",15) I X]"",'$D(^PRC(442,"AB",X,N)) S ^PRC(442,"AB",X,N)=""
- . I $P(N0,"^",2)=21,X="" D 1358(N,N0,N1)
- . QUIT
- D END^PRCGU
- QUIT
- 1358(DA,DA0,DA1) ;correct 1358's without po dates in 442
- N OB,OK,X
- ;If obligation data, take date of first code sheet
- S OB=$O(^PRC(442,DA,10,0)) I +OB D QUIT:$D(OK)
- . 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
- . QUIT
- ;If no obligation data, take date of first entry in 424
- S OB=$O(^PRC(424,"C",DA,0)) I +OB D QUIT:$D(OK)
- . S X=$P($G(^PRC(424,OB,0)),"^",7) I $E(X,1,7)?7N D SET QUIT
- . QUIT
- ;If no entries in 424 take Date P.O. Assigned
- S X=$P($G(^PRC(442,DA,12)),"^",5) I $E(X,1,7)?7N D SET QUIT:$D(OK)
- QUIT
- SET ;Places date in P.O. Date field and sets xref
- S X=$E(X,1,7)
- S $P(DA1,"^",15)=X,^PRC(442,DA,1)=DA1,^PRC(442,"AC",X,DA)=""
- S OK=1 QUIT
- EXIT QUIT
- ;
- FILE S $P(^PRCS(410,DA,1),"^",1)=X
- QUIT
- DOR(DA) ;CLEANUP DATE OF REQUEST FIELD
- N X,Y
- F I=0,1,3,4,5,6,7 S X(I)=$G(^PRCS(410,DA,I))
- Q:$P(X(1),"^",1)]"" ;QUIT WHEN DATE OF REQUEST PRESENT
- S X=$P($P(X(4),"^",4),".",1)]"" I X]"" D FILE QUIT
- S X=$P($P(X(1),"^",4),".",1)]"" I X]"" D FILE QUIT
- S X=$P($P(X(7),"^",5),".",1)]"" I X]"" D FILE QUIT
- S X=$P($P(X(6),"^",2),".",1)]"" I X]"" D FILE QUIT
- S X=$P($P(X(4),"^",13),".",1)]"" I X]"" D FILE QUIT
- S X=$P($P(X(5),"^",2),".",1)]"" I X]"" D FILE QUIT
- S X=$P($P(X(7),"^",7),".",1)]"" I X]"" D FILE QUIT
- S X=$P($P(X(7),"^",10),".",1)]"" I X]"" D FILE QUIT
- S X=$P($P(X(4),"^",7),".",1)]"" I X]"" D FILE QUIT
- S X=$P($P(X(4),"^",2),".",1)]"" I X]"" D FILE QUIT
- S X=$P($P(X(0),"^",8),".",1)]"" I X]"" D QUIT
- . N Y S Y=$E(X,4,5),Y=$S("01,03,05,07,08,10,12"[Y:31,Y=2:28,1:30)
- . S X=$E(X,1,5)_Y D FILE QUIT
- I $P(X(0),"^",1)?3N1"-"2N1"-"1N1"-"3.4N1"-"4N S X=$$EOFY(X(0)) I X]"" D FILE QUIT
- I $P(X(0),"^",12)="E" S X=$P(DT,".") D FILE QUIT
- D KILL410
- QUIT
- EOFY(Y) S X="",X=$P(Y,"-",2),X=$S(X>70:"2"_X,1:"3"_X)_"0930" QUIT X
- KILL410 D KILL410^PRCGARP1(DA) ;WHEN NO DATES OR GARBAGE, REMOVE RECORD
- S KILLFLAG=""
- QUIT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCGA 3134 printed Feb 18, 2025@23:31:05 Page 2
- PRCGA ;WIRMFO/CTB/PLT - POST INIT - IFCAP PURGE ;12/23/96 2:27 PM
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 NEW DA,PRC442,PRCA,PRCB,ZTSTOP,X,Y
- ETM SET PRCA=""
- SET ZTSTOP=""
- +1 SET MESSAGE="UPDATING PURCHASE ORDER DATE FIELD AND XREF IN FILES 410 AND 442"
- SET ITEMS="documents"
- +2 SET TREC=$PIECE(^PRCS(410,0),"^",4)+$PIECE(^PRC(442,0),"^",4)
- +3 DO BEGIN^PRCGU
- +4 SET PRCSDA=0
- +5 FOR
- Begin DoDot:1
- +6 FOR COUNT=1:1:LREC
- SET PRCSDA=$ORDER(^PRCS(410,PRCSDA))
- if 'PRCSDA
- QUIT
- Begin DoDot:2
- +7 DO DOR(PRCSDA)
- IF $DATA(KILLFLAG)
- KILL KILLFLAG
- QUIT
- +8 SET PRCB=$GET(^PRCS(410,PRCSDA,0))
- if $PIECE(PRCB,"^",4)'=1
- QUIT
- +9 SET PRCB=$GET(^PRCS(410,PRCSDA,10))
- SET PRC442=$PIECE(PRCB,"^",3)
- if PRC442=""
- QUIT
- +10 SET PRCB=$GET(^PRCS(410,PRCSDA,4))
- if $PIECE(PRCB,"^",5)=""!($PIECE(PRCB,"^",4)="")
- QUIT
- +11 if $PIECE($GET(^PRC(442,PRC442,1)),"^",15)'=""
- QUIT
- +12 SET DA=PRC442
- SET DIE="^PRC(442,"
- SET DR=".1////"_$PIECE(PRCB,"^",4)
- DO ^DIE
- +13 QUIT
- End DoDot:2
- +14 QUIT
- End DoDot:1
- SET XCOUNT=XCOUNT+COUNT
- DO PERCENT^PRCGU
- if 'PRCSDA
- QUIT
- +15 SET N=0
- FOR
- Begin DoDot:1
- +16 FOR COUNT=1:1:LREC
- SET N=$ORDER(^PRC(442,N))
- if 'N
- QUIT
- Begin DoDot:2
- End DoDot:2
- +17 SET N0=$GET(^(N,0))
- SET N1=$GET(^(1))
- +18 SET X=$PIECE(N1,"^",15)
- IF X]""
- IF '$DATA(^PRC(442,"AB",X,N))
- SET ^PRC(442,"AB",X,N)=""
- +19 IF $PIECE(N0,"^",2)=21
- IF X=""
- DO 1358(N,N0,N1)
- +20 QUIT
- End DoDot:1
- SET XCOUNT=XCOUNT+COUNT
- DO PERCENT^PRCGU
- if 'N
- QUIT
- +21 DO END^PRCGU
- +22 QUIT
- 1358(DA,DA0,DA1) ;correct 1358's without po dates in 442
- +1 NEW OB,OK,X
- +2 ;If obligation data, take date of first code sheet
- +3 SET OB=$ORDER(^PRC(442,DA,10,0))
- IF +OB
- Begin DoDot:1
- +4 SET X=$PIECE($GET(^PRC(442,DA,10,OB,0)),"^",1)
- IF $PIECE(X,".",3)?6N
- SET X="2"_$PIECE(X,".",3)
- DO SET
- QUIT
- +5 QUIT
- End DoDot:1
- if $DATA(OK)
- QUIT
- +6 ;If no obligation data, take date of first entry in 424
- +7 SET OB=$ORDER(^PRC(424,"C",DA,0))
- IF +OB
- Begin DoDot:1
- +8 SET X=$PIECE($GET(^PRC(424,OB,0)),"^",7)
- IF $EXTRACT(X,1,7)?7N
- DO SET
- QUIT
- +9 QUIT
- End DoDot:1
- if $DATA(OK)
- QUIT
- +10 ;If no entries in 424 take Date P.O. Assigned
- +11 SET X=$PIECE($GET(^PRC(442,DA,12)),"^",5)
- IF $EXTRACT(X,1,7)?7N
- DO SET
- if $DATA(OK)
- QUIT
- +12 QUIT
- SET ;Places date in P.O. Date field and sets xref
- +1 SET X=$EXTRACT(X,1,7)
- +2 SET $PIECE(DA1,"^",15)=X
- SET ^PRC(442,DA,1)=DA1
- SET ^PRC(442,"AC",X,DA)=""
- +3 SET OK=1
- QUIT
- EXIT QUIT
- +1 ;
- FILE SET $PIECE(^PRCS(410,DA,1),"^",1)=X
- +1 QUIT
- DOR(DA) ;CLEANUP DATE OF REQUEST FIELD
- +1 NEW X,Y
- +2 FOR I=0,1,3,4,5,6,7
- SET X(I)=$GET(^PRCS(410,DA,I))
- +3 ;QUIT WHEN DATE OF REQUEST PRESENT
- if $PIECE(X(1),"^",1)]""
- QUIT
- +4 SET X=$PIECE($PIECE(X(4),"^",4),".",1)]""
- IF X]""
- DO FILE
- QUIT
- +5 SET X=$PIECE($PIECE(X(1),"^",4),".",1)]""
- IF X]""
- DO FILE
- QUIT
- +6 SET X=$PIECE($PIECE(X(7),"^",5),".",1)]""
- IF X]""
- DO FILE
- QUIT
- +7 SET X=$PIECE($PIECE(X(6),"^",2),".",1)]""
- IF X]""
- DO FILE
- QUIT
- +8 SET X=$PIECE($PIECE(X(4),"^",13),".",1)]""
- IF X]""
- DO FILE
- QUIT
- +9 SET X=$PIECE($PIECE(X(5),"^",2),".",1)]""
- IF X]""
- DO FILE
- QUIT
- +10 SET X=$PIECE($PIECE(X(7),"^",7),".",1)]""
- IF X]""
- DO FILE
- QUIT
- +11 SET X=$PIECE($PIECE(X(7),"^",10),".",1)]""
- IF X]""
- DO FILE
- QUIT
- +12 SET X=$PIECE($PIECE(X(4),"^",7),".",1)]""
- IF X]""
- DO FILE
- QUIT
- +13 SET X=$PIECE($PIECE(X(4),"^",2),".",1)]""
- IF X]""
- DO FILE
- QUIT
- +14 SET X=$PIECE($PIECE(X(0),"^",8),".",1)]""
- IF X]""
- Begin DoDot:1
- +15 NEW Y
- SET Y=$EXTRACT(X,4,5)
- SET Y=$SELECT("01,03,05,07,08,10,12"[Y:31,Y=2:28,1:30)
- +16 SET X=$EXTRACT(X,1,5)_Y
- DO FILE
- QUIT
- End DoDot:1
- QUIT
- +17 IF $PIECE(X(0),"^",1)?3N1"-"2N1"-"1N1"-"3.4N1"-"4N
- SET X=$$EOFY(X(0))
- IF X]""
- DO FILE
- QUIT
- +18 IF $PIECE(X(0),"^",12)="E"
- SET X=$PIECE(DT,".")
- DO FILE
- QUIT
- +19 DO KILL410
- +20 QUIT
- EOFY(Y) SET X=""
- SET X=$PIECE(Y,"-",2)
- SET X=$SELECT(X>70:"2"_X,1:"3"_X)_"0930"
- QUIT X
- KILL410 ;WHEN NO DATES OR GARBAGE, REMOVE RECORD
- DO KILL410^PRCGARP1(DA)
- +1 SET KILLFLAG=""
- +2 QUIT