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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHCS6 1181 printed Nov 22, 2024@17:16:28 Page 2
PRCHCS6 ;WISC/RHD-BUILD LOG CODE SHEET DATA ;12/1/93 09:52
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;ISSUE REQUEST
+1 SET PRCHTP(1,1)="57;5.2"
SET PRCHTP(1,2)="59;305"
SET PRCHTP(1,3)="58;333"
SET PRCHTP(1,4)="S X=PRCHDPT;330"
SET PRCHTP(1,5)="S X="_PRC("SITE")_";1"
+2 SET PRCHTP(1,6)="S X="_PRCFA("TT")_";3"
+3 DO CC
SET PRCHTP(1,7)="S X="_PRCHCC_";315"
SET PRCHTP(1,8)="S X="""_PRCHCP_""";314"
+4 SET PRCHTP(2,1)="2;302"
SET 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"
SET PRCHTP(2,3)="S X=$P(PRCH0,U,1);300"
+5 SET PRCHTP(2,4)="3;303"
SET PRCHTP(2,5)="S Y=$E($P(PRCHI0,U,2),1,21),PRCFLN=21 D RBF^PRCFU S X=Y;309"
SET PRCHTP(2,6)="D DNSUB^PRCHCS6;331"
SET PRCHTP(2,7)="D DNBO^PRCHCS6;332"
+6 QUIT
CC SET PRCHCC="""000000"""
IF PRCFA("TT")'=669
IF $DATA(^PRCS(410,PRCHR,3))
IF $PIECE(^(3),U,3)
SET PRCHCC=+$PIECE(^(3),U,3)
SET PRCHCC=$SELECT($DATA(^PRCD(420.1,PRCHCC,0)):PRCHCC,1:"""000000""")
+1 QUIT
DNSUB SET X=$PIECE($GET(^PRCP(445,+$PIECE(^PRCS(410,PRCHR,0),U,6),1,+$PIECE(^PRCS(410,PRCHR,"IT",PRCHLI,0),U,5),0)),U,18)
+1 QUIT
DNBO SET X=$PIECE($GET(^PRCP(445,+$PIECE(^PRCS(410,PRCHR,0),U,6),1,+$PIECE(^PRCS(410,PRCHR,"IT",PRCHLI,0),U,5),0)),U,13)
+1 QUIT
