- PRCHHI2 ;WISC/TGH-IFCAP SEGMENT BI ;10/2/92 4:15 PM
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- BI(A,A2,VAR1,CNTR,NUM) ;BILL TO INFORMATION SEGMENT
- N IA,STRNG,ZIP
- S PRCHSITE=+$P(A,U),A12=$G(^PRC(442,VAR1,12))
- S IA=+$P(A12,U,6)
- S PRCHINV=$G(^PRC(411,PRCHSITE,4,IA,0))
- S PRCHTP(1,CNTR+1)="S X=""|BI"";513"
- S PRCHTP(1,CNTR+2)="S X=PRCHSITE;513.1"
- S PRCHTP(1,CNTR+3)="S X=$P(PRCHINV,U);513.2"
- S PRCHTP(1,CNTR+4)="S X=$P(PRCHINV,U,2);513.3"
- S PRCHTP(1,CNTR+5)="S X=$P(PRCHINV,U,3);513.4"
- S PRCHTP(1,CNTR+6)="S X=$P(PRCHINV,U,4);513.5"
- S PRCHTP(1,CNTR+7)="S X=$P(PRCHINV,U,5);513.7"
- S PRCHST=$G(^DIC(5,+$P(PRCHINV,U,6),0))
- S ZIP=$P(PRCHINV,U,7)
- I ZIP]"",ZIP'?.N N B,I S B="" D S ZIP=B
- .F I=1:1:$L(ZIP) S:$E(ZIP,I)?1N B=B_$E(ZIP,I)
- .Q
- S PRCHTP(1,CNTR+8)="S X=$P(PRCHST,U,2);513.8"
- S PRCHTP(1,CNTR+9)="S X=$P(PRCHINV,U,7);513.9"
- S STRNG="BI"_"^"_$P(PRCHINV,U,8)_"^"_$P(PRCHINV,U,1,4)_"^^^^^"_$P(PRCHINV,U,5)_"^"_$P(PRCHST,U,2)_"^"_ZIP_"^|"
- S NUM=NUM+1,^TMP($J,"STRING",NUM)=STRNG
- S CNTR=CNTR+9
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHHI2 1092 printed Feb 18, 2025@23:34:11 Page 2
- PRCHHI2 ;WISC/TGH-IFCAP SEGMENT BI ;10/2/92 4:15 PM
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- BI(A,A2,VAR1,CNTR,NUM) ;BILL TO INFORMATION SEGMENT
- +1 NEW IA,STRNG,ZIP
- +2 SET PRCHSITE=+$PIECE(A,U)
- SET A12=$GET(^PRC(442,VAR1,12))
- +3 SET IA=+$PIECE(A12,U,6)
- +4 SET PRCHINV=$GET(^PRC(411,PRCHSITE,4,IA,0))
- +5 SET PRCHTP(1,CNTR+1)="S X=""|BI"";513"
- +6 SET PRCHTP(1,CNTR+2)="S X=PRCHSITE;513.1"
- +7 SET PRCHTP(1,CNTR+3)="S X=$P(PRCHINV,U);513.2"
- +8 SET PRCHTP(1,CNTR+4)="S X=$P(PRCHINV,U,2);513.3"
- +9 SET PRCHTP(1,CNTR+5)="S X=$P(PRCHINV,U,3);513.4"
- +10 SET PRCHTP(1,CNTR+6)="S X=$P(PRCHINV,U,4);513.5"
- +11 SET PRCHTP(1,CNTR+7)="S X=$P(PRCHINV,U,5);513.7"
- +12 SET PRCHST=$GET(^DIC(5,+$PIECE(PRCHINV,U,6),0))
- +13 SET ZIP=$PIECE(PRCHINV,U,7)
- +14 IF ZIP]""
- IF ZIP'?.N
- NEW B,I
- SET B=""
- Begin DoDot:1
- +15 FOR I=1:1:$LENGTH(ZIP)
- if $EXTRACT(ZIP,I)?1N
- SET B=B_$EXTRACT(ZIP,I)
- +16 QUIT
- End DoDot:1
- SET ZIP=B
- +17 SET PRCHTP(1,CNTR+8)="S X=$P(PRCHST,U,2);513.8"
- +18 SET PRCHTP(1,CNTR+9)="S X=$P(PRCHINV,U,7);513.9"
- +19 SET STRNG="BI"_"^"_$PIECE(PRCHINV,U,8)_"^"_$PIECE(PRCHINV,U,1,4)_"^^^^^"_$PIECE(PRCHINV,U,5)_"^"_$PIECE(PRCHST,U,2)_"^"_ZIP_"^|"
- +20 SET NUM=NUM+1
- SET ^TMP($JOB,"STRING",NUM)=STRNG
- +21 SET CNTR=CNTR+9
- +22 QUIT