- 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 Mar 13, 2025@21:07:18 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
