PRCFARR1 ;ISC-SF/TKW-CONT. OF RR FOR TRANSMISSION ;5/11/94 1:01 PM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;#6 FISCAL DATA-PURCH.AUTHORITY,CONTRACTING OFFICER,P.O.DATE,TOTAL AMT.OF P.O.,APPROPRIATION,COST CENTER,FUND CONTROL PT.,OBLIGATED BY
S X="" F I=0:0 S I=$O(^PRC(442,PRCFPO,14,I)) Q:'I S Y=+^(I,0) I $D(^PRC(442.4,Y,0)) S:X]"" X=X_"," S X=X_$P(^(0),"^",2)
S PRCFX="6^"_X_"^",DA=PRCFPO,X=$$DECODE^PRCHES5(PRCFPO)
D RUP^PRCFARR3 S $P(X," ",35)=" ",X=$E(X,1,34)_" ",Y=$P(PRCF12,"^",3)
S X=X_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_"@"
S X=X_$E(Y,9,10)_":"_$E(Y,11,12),$P(PRCFX,"^",3)=X
S X=$P(PRCF1,"^",15),$P(PRCFX,"^",4)=$E(X,4,7)_$E(X,2,3)
S X=$P(PRCF0,"^",15) D FAMT^PRCFARR S $P(PRCFX,"^",5)=X
;S X="000000"_+$E($P(PRCF0,"^",5),1,6),X=$E(X,($L(X)-5),$L(X))
;S $P(PRCFX,"^",6,8)=$P(PRCF0,"^",4)_"^"_X_"^"_$P($P(PRCF0,"^",3)," ")_"^"
;I $D(^PRC(442,PRCFPO,10,1,0)),$P(^(0),"^",5)]"" S X=$$DECODE^PRCHES4(PRCFPO,1)
S ^TMP("PRCFARR",$J,6,0)=PRCFX_"^"
;#7 PAT BOCS & AMOUNTS,WHSE.SIGNATURE & RCVD.DATE,SERVICE SIGNATURE & RCVD.DATE
S PRCFX="7^" ;I $P(PRCF0,"^",7)=$P(PRCF11,"^",3)&($P(PRCF0,"^",9)=$P(PRCF11,"^",5)) G E1
;S Z=$S($P(PRCF0,"^",8):$P(PRCF0,"^",6),1:""),X=$P(PRCF0,"^",7) D FAMT^PRCFARR S $P(PRCFX,"^",2,3)=Z_"^"_X
;S X=$P(PRCF0,"^",9) D FAMT^PRCFARR S $P(PRCFX,"^",4,5)=$P(PRCF0,"^",8)_"^"_X
E1 S Z="",X=$$DECODE^PRCHES1(PRCFPO,PRCFPR) D RUP^PRCFARR3
S $P(PRCFX,"^",2)=X
S $P(PRCFX,"^",3)=$E($P(PRCF11,"^",11),4,7)_$E($P(PRCF11,"^",11),2,3)_"^^"
I $P(PRCF11,"^",16)]"" D
.S X=$$DECODE^PRCHES2(PRCFPO,PRCFPR) D RUP^PRCFARR3
.S $P(PRCFX,"^",4)=X
.S $P(PRCFX,"^",5)=$E($P(PRCF11,"^",17),4,7)_$E($P(PRCF11,"^",17),2,3)
.Q
S ^TMP("PRCFARR",$J,7,0)=PRCFX_"^",$P(^(0),U,6)=""
G EN^PRCFARR2
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFARR1 1818 printed Dec 13, 2024@02:02:30 Page 2
PRCFARR1 ;ISC-SF/TKW-CONT. OF RR FOR TRANSMISSION ;5/11/94 1:01 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;#6 FISCAL DATA-PURCH.AUTHORITY,CONTRACTING OFFICER,P.O.DATE,TOTAL AMT.OF P.O.,APPROPRIATION,COST CENTER,FUND CONTROL PT.,OBLIGATED BY
+1 SET X=""
FOR I=0:0
SET I=$ORDER(^PRC(442,PRCFPO,14,I))
if 'I
QUIT
SET Y=+^(I,0)
IF $DATA(^PRC(442.4,Y,0))
if X]""
SET X=X_","
SET X=X_$PIECE(^(0),"^",2)
+2 SET PRCFX="6^"_X_"^"
SET DA=PRCFPO
SET X=$$DECODE^PRCHES5(PRCFPO)
+3 DO RUP^PRCFARR3
SET $PIECE(X," ",35)=" "
SET X=$EXTRACT(X,1,34)_" "
SET Y=$PIECE(PRCF12,"^",3)
+4 SET X=X_$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)_"@"
+5 SET X=X_$EXTRACT(Y,9,10)_":"_$EXTRACT(Y,11,12)
SET $PIECE(PRCFX,"^",3)=X
+6 SET X=$PIECE(PRCF1,"^",15)
SET $PIECE(PRCFX,"^",4)=$EXTRACT(X,4,7)_$EXTRACT(X,2,3)
+7 SET X=$PIECE(PRCF0,"^",15)
DO FAMT^PRCFARR
SET $PIECE(PRCFX,"^",5)=X
+8 ;S X="000000"_+$E($P(PRCF0,"^",5),1,6),X=$E(X,($L(X)-5),$L(X))
+9 ;S $P(PRCFX,"^",6,8)=$P(PRCF0,"^",4)_"^"_X_"^"_$P($P(PRCF0,"^",3)," ")_"^"
+10 ;I $D(^PRC(442,PRCFPO,10,1,0)),$P(^(0),"^",5)]"" S X=$$DECODE^PRCHES4(PRCFPO,1)
+11 SET ^TMP("PRCFARR",$JOB,6,0)=PRCFX_"^"
+12 ;#7 PAT BOCS & AMOUNTS,WHSE.SIGNATURE & RCVD.DATE,SERVICE SIGNATURE & RCVD.DATE
+13 ;I $P(PRCF0,"^",7)=$P(PRCF11,"^",3)&($P(PRCF0,"^",9)=$P(PRCF11,"^",5)) G E1
SET PRCFX="7^"
+14 ;S Z=$S($P(PRCF0,"^",8):$P(PRCF0,"^",6),1:""),X=$P(PRCF0,"^",7) D FAMT^PRCFARR S $P(PRCFX,"^",2,3)=Z_"^"_X
+15 ;S X=$P(PRCF0,"^",9) D FAMT^PRCFARR S $P(PRCFX,"^",4,5)=$P(PRCF0,"^",8)_"^"_X
E1 SET Z=""
SET X=$$DECODE^PRCHES1(PRCFPO,PRCFPR)
DO RUP^PRCFARR3
+1 SET $PIECE(PRCFX,"^",2)=X
+2 SET $PIECE(PRCFX,"^",3)=$EXTRACT($PIECE(PRCF11,"^",11),4,7)_$EXTRACT($PIECE(PRCF11,"^",11),2,3)_"^^"
+3 IF $PIECE(PRCF11,"^",16)]""
Begin DoDot:1
+4 SET X=$$DECODE^PRCHES2(PRCFPO,PRCFPR)
DO RUP^PRCFARR3
+5 SET $PIECE(PRCFX,"^",4)=X
+6 SET $PIECE(PRCFX,"^",5)=$EXTRACT($PIECE(PRCF11,"^",17),4,7)_$EXTRACT($PIECE(PRCF11,"^",17),2,3)
+7 QUIT
End DoDot:1
+8 SET ^TMP("PRCFARR",$JOB,7,0)=PRCFX_"^"
SET $PIECE(^(0),U,6)=""
+9 GOTO EN^PRCFARR2
