PRCHCS6 ;WISC/RHD-BUILD LOG CODE SHEET DATA ;12/1/93  09:52
V ;;5.1;IFCAP;;Oct 20, 2000
 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;ISSUE REQUEST
 S PRCHTP(1,1)="57;5.2",PRCHTP(1,2)="59;305",PRCHTP(1,3)="58;333",PRCHTP(1,4)="S X=PRCHDPT;330",PRCHTP(1,5)="S X="_PRC("SITE")_";1"
 S PRCHTP(1,6)="S X="_PRCFA("TT")_";3"
 D CC S PRCHTP(1,7)="S X="_PRCHCC_";315",PRCHTP(1,8)="S X="""_PRCHCP_""";314"
 S PRCHTP(2,1)="2;302",PRCHTP(2,2)="S PRCHNSN=$P(PRCHI0,U,5),X=$P(PRCHNSN,""-"",2)_$P(PRCHNSN,""-"",3)_$P(PRCHNSN,""-"",4),X=X_$S($L(X)=9:"" "",1:"""");308",PRCHTP(2,3)="S X=$P(PRCH0,U,1);300"
 S PRCHTP(2,4)="3;303",PRCHTP(2,5)="S Y=$E($P(PRCHI0,U,2),1,21),PRCFLN=21 D RBF^PRCFU S X=Y;309",PRCHTP(2,6)="D DNSUB^PRCHCS6;331",PRCHTP(2,7)="D DNBO^PRCHCS6;332"
 Q
CC S PRCHCC="""000000""" I PRCFA("TT")'=669,$D(^PRCS(410,PRCHR,3)),$P(^(3),U,3) S PRCHCC=+$P(^(3),U,3),PRCHCC=$S($D(^PRCD(420.1,PRCHCC,0)):PRCHCC,1:"""000000""")
 Q
DNSUB S X=$P($G(^PRCP(445,+$P(^PRCS(410,PRCHR,0),U,6),1,+$P(^PRCS(410,PRCHR,"IT",PRCHLI,0),U,5),0)),U,18)
 Q
DNBO S X=$P($G(^PRCP(445,+$P(^PRCS(410,PRCHR,0),U,6),1,+$P(^PRCS(410,PRCHR,"IT",PRCHLI,0),U,5),0)),U,13)
 Q