PRCHCS6.m

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 ---PRCHCS6   1181     printed  Apr 09, 2024@21:13:36                                                                                                                                                                                                     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