Routine: PRCH7A

PRCH7A ;WISC/PLT-Receiver documents - ORA from ORACLE ; 07/01/98  3:37 PM

V ;;5.1;IFCAP;**20,233**;Oct 20, 2000;Build 3

 ;;Per VA Directive 6402, this routine should not be modified.

 QUIT  ;invalid entry

 ;invoked from task manager (see trin^prcosrv2)

 ;convert message to file 440.6

 ;PRCDA=ri of file 423.6 passed

CCR ;Conversion CCR message from FMS MESSAGE SEVER routine PRCOSRV2

 N PRCRI,PRCEDIT,PRCTY,PRCERR,PRCSEQ,PRCEX,A,B

 S PRCRI(423.6)=PRCDA,PRCTY=""

 ;copy ORACLE records to file 440.6

 D ICLOCK^PRC0B("^PRCH(440.8,")

 D COPY(PRCRI(423.6))

 D DCLOCK^PRC0B("^PRCH(440.8,")

EXIT ;delete ORACLE message in file 423.6

 D KILL^PRCOSRV3(PRCRI(423.6))

 QUIT

COPY(PRCA) ;PRCA=ri of file 423.6

 N PRCRI,PRCC,PRCD,PRCE,PRCT,PRCDUZ,PRCTTC,PRCDO,PRCEX,PRCSYS

 N A,B,PRCX,X,Y

 S PRCSYS=1

 S X="NEW",X("DR")="1///NOW;6///T" D ADD^PRC0B1(.X,.Y,"440.8;^PRCH(440.8,") QUIT:Y<1

 S PRCRI(440.8)=+Y

 S PRCC=$O(^PRCF(423.6,PRCA,1,9999)),PRCTTC=0

 D EDIT^PRC0B(.X,"440.8;^PRCH(440.8,;"_PRCRI(440.8),"2///NOW")

 F  S PRCC=$O(^PRCF(423.6,PRCA,1,PRCC)) Q:'PRCC  S PRCD=^(PRCC,0) D:PRCD["~"

 . S PRCT=$P(PRCD,"^")

 . S PRCX=$P(PRCD,"^",22)

 . D:PRCT="CCT"

 .. D EDIT^PRC0B(.X,"440.8;^PRCH(440.8,;"_PRCRI(440.8),".01////"_$P(PRCD,"^",3)_";4////"_$P(PRCD,"^",2))

 .. QUIT

 . D:PRCT="CCR"

 .. S PRCTTC=PRCTTC+1,PRCE="C"_$P(PRCD,"^",2)_$P(PRCD,"^",4),PRCRI(440.6)=$O(^PRCH(440.6,"B",PRCE,""))

 .. I PRCRI(440.6) QUIT:$P(^PRCH(440.6,PRCRI(440.6),0),"^",16)'="N"&($P(^(0),"^",16)]"")

 .. I 'PRCRI(440.6) S X=PRCE D ADD^PRC0B1(.X,.Y,"440.6;^PRCH(440.6,") QUIT:Y<1  S PRCRI(440.6)=+Y

 .. S PRCDUZ="" I $P(PRCD,"^",5)]"" S PRCRI(440.5)=$O(^PRC(440.5,"B",$P(PRCD,"^",5),"")) I PRCRI(440.5) S PRCDUZ=$P(^PRC(440.5,PRCRI(440.5),0),"^",8)

 .. S X="1////"_$P(PRCD,"^",3)_";2////"_$P(PRCD,"^",4)_";3////"_$P(PRCD,"^",5)_";4////"_$P(PRCD,"^",6)_";7////"_$P(PRCD,"^",9)_";9////"_$P(PRCD,"^",11)_";12////"_$P(PRCD,"^",14)_";13////"_$P(PRCD,"^",15)_";14////"_$P(PRCD,"^",21)

 .. S X(1,440.6,1)="20////^S X=PRCX"_";21////"_$P(PRCD,"^",16)_";22////"_$P(PRCD,"^",17)_";23////"_$P(PRCD,"^",18)_";24////"_$P(PRCD,"^",19)_";25////"_$P(PRCD,"^",20)_";16////"_PRCDUZ

 .. D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"")

 .. ;edit date fields and status

 .. F A=7,10 S B=$P(PRCD,"^",A),$P(PRCD,"^",A)=$E(B,3,4)_"/"_$E(B,5,6)_"/"_$E(B,1,2)

 .. S B=$P(PRCD,"^",8),$P(PRCD,"^",8)=$E(B,1,2)_"/"_$E(B,3,4)_"/"_$E(B,5,6)

 .. S:$P(PRCD,"^",13)="" $P(PRCD,"^",13)=$P(PRCD,"^",12)

 .. S A="15////N;8///"_$P(PRCD,"^",10)_";6///"_$P(PRCD,"^",8)_";5///"_$P(PRCD,"^",7)_";10///"_$P(PRCD,"^",12)_";11///"_$P(PRCD,"^",13)

 .. D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),A)

 .. QUIT

 . D:PRCT="CC1"&$G(PRCRI(440.6))

 .. S A="31////"_$TR($P(PRCD,"^",2),";","-")_";32////"_$P(PRCD,"^",3)_";33////"_$P(PRCD,"^",4)_";34////"_$P(PRCD,"^",5)_";35////"_$P(PRCD,"^",6)_";36////"_$TR($P(PRCD,"^",7,8),"^","")    ;PRC*5.1*233

 .. D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),A)

 .. S PRCRI(440.6)=""

 .. QUIT

 . ;new purchase card data from AFS

 . D:PRCT="CCD"

 .. S PRCTTC=PRCTTC+1,PRCEDIT=0,PRCE=$P(PRCD,"^",2),PRCRI(440.5)=$O(^PRC(440.5,"B",PRCE,""))

 .. S:PRCRI(440.5) PRCEDIT=1

 .. I 'PRCRI(440.5) S X=PRCE D ADD^PRC0B1(.X,.Y,"440.5;^PRC(440.5,") QUIT:Y<1  S PRCRI(440.5)=+Y

 .. S PRCE="51////"_$P(PRCD,"^",3)_$$CCNR^PRCH0A($P(PRCD,"^",3)),$P(PRCE,";",2)="52////"_$P(PRCD,"^",6)

 .. S $P(PRCE,";",3)="53////"_$P(PRCD,"^",7)_$$ST^PRCH0A($P(PRCD,"^",7))_$$STR^PRCH0A($P(PRCD,"^",3),$P(PRCD,"^",7))

 .. S $P(PRCE,";",4)="54////"_$P(PRCD,"^",4)

 .. S $P(PRCE,";",5)="55////"_$P(PRCD,"^",9)_$$FC^PRCH0A($P(PRCD,"^",9))_$$FCR^PRCH0A($P(PRCD,"^",3),$P(PRCD,"^",9))

 .. S $P(PRCE,";",6)="56////"_$P(PRCD,"^",10)_$$ACC^PRCH0A($P(PRCD,"^",10))_$$ACCR^PRCH0A($P(PRCD,"^",3),$P(PRCD,"^",10))

 .. S $P(PRCE,";",7)="57////"_$P(PRCD,"^",11)_$$CC^PRCH0A($P(PRCD,"^",11))_$$CCR^PRCH0A($P(PRCD,"^",3),$P(PRCD,"^",11))

 .. S $P(PRCE(1,440.5,1),";",1)="58////"_$P(PRCD,"^",12)_$$BOC^PRCH0A($P(PRCD,"^",12),$P(PRCD,"^",11))_$$BOCR^PRCH0A($P(PRCD,"^",3),$P(PRCD,"^",12))

 .. S B=$P(PRCD,"^",5),B=$E(B,5,6)_"/"_$E(B,7,8)_"/"_$E(B,1,4)

 .. S A=$$FFVV^PRCH0A(440.5,16,B),B="" S:'$P(PRCD,"^",5)!'A B="*"

 .. S $P(PRCE(1,440.5,1),";",2)="59////"_$P(PRCD,"^",5)_B

 .. S $P(PRCE(1,440.5,1),";",3)="60////"_$P(PRCD,"^",2)_$$CCN^PRCH0A($P(PRCD,"^",2))

 .. S A=$$FFVV^PRCH0A(440.5,4,$P(PRCD,"^",14)),B="" S:$P(PRCD,"^",14)>$P(PRCD,"^",15)!'A!'$P(PRCD,"^",14) B="*" S $P(PRCE(1,440.5,1),";",4)="61////"_$P(PRCD,"^",14)_B

 .. S A=$$FFVV^PRCH0A(440.5,5,$P(PRCD,"^",15)),B="" S:$P(PRCD,"^",15)<$P(PRCD,"^",14)!'A!'$P(PRCD,"^",15) B="*" S $P(PRCE(1,440.5,1),";",5)="62////"_$P(PRCD,"^",15)_B

 ..D EDIT^PRC0B(.PRCE,"440.5;^PRC(440.5,;"_PRCRI(440.5),"") K PRCE

 .. I $P(PRCD,"^",3)]"" S $P(PRCD,"^",3)=$O(^PRC(440.5,"B",$P(PRCD,"^",3),0))

 .. S PRCDO="" I $P(PRCD,"^",3) S PRCDO=$G(^PRC(440.5,$P(PRCD,"^",3),0)) S A="6////"_$P(PRCDO,"^",7)_";7////"_$P(PRCDO,"^",8)_";8////"_$P(PRCDO,"^",9)_";9////"_$P(PRCDO,"^",10)_";10////"_$P(PRCDO,"^",11) D

 ... D EDIT^PRC0B(.X,"440.5;^PRC(440.5,;"_PRCRI(440.5),A)

 ... QUIT

 .. I $P(PRCD,"^",3) S PRCRI=$P(PRCD,"^",3),PRCRI(440.512)=0 F  S PRCRI(440.512)=$O(^PRC(440.5,PRCRI,1,PRCRI(440.512))) QUIT:PRCRI(440.512)<1  S B=$G(^(PRCRI(440.512),0)) D

 ... S X=$P(B,"^") I X,'$D(^PRC(440.5,PRCRI(440.5),1,+X)) D ADD^PRC0B1(.X,.Y,"440.5;^PRC(440.5,;"_PRCRI(440.5)_";12~440.512;^PRC(440.5,"_PRCRI(440.5)_",1,",+X)

 ... QUIT

 .. S A=$G(^PRC(440.5,PRCRI(440.5),0)),B=$G(^(50)),C=$G(^(2)),D=1,PRCE=""

 .. S D=1 I $P(A,"^",8)]"",$P(PRCD,"^",7)]"",$P(PRCDO,"^",2)]"" S $P(PRCE,";",D)="63////"_$P($P(PRCDO,"^",2)," ")_$$UFCP^PRCH0A($P(A,"^",8),$P(PRCD,"^",7),$P(PRCDO,"^",2)),D=D+1

 .. D:PRCE]"" EDIT^PRC0B(.X,"440.5;^PRC(440.5,;"_PRCRI(440.5),PRCE)

 .. S PRCEX="",A=$G(^PRC(440.5,PRCRI(440.5),50)) S:A["*" PRCEX=PRCEX_"*" S:A["#" PRCEX=PRCEX_"#"

 .. D EDIT^PRC0B(.X,"440.5;^PRC(440.5,;"_PRCRI(440.5),"14////"_$S(PRCEX["*":"Y",1:"N")_";70////"_$S(PRCEX]"":"E",1:"P")_";71////"_DT)

 .. I PRCEX'["*" D

 ... S PRCE=$G(^PRC(440.5,PRCRI(440.5),50))

 ... D EDIT^PRC0B(.X,"440.5;^PRC(440.5,;"_PRCRI(440.5),"4////"_$P(PRCE,"^",11))

 ... D EDIT^PRC0B(.X,"440.5;^PRC(440.5,;"_PRCRI(440.5),"5////"_$P(PRCE,"^",12))

 ... S B=$P(PRCE,"^",9) D EDIT^PRC0B(.X,"440.5;^PRC(440.5,;"_PRCRI(440.5),"16///"_$E(B,5,6)_"/"_$E(B,7,8)_"/"_$E(B,1,4))

 ... D EDIT^PRC0B(.X,"440.5;^PRC(440.5,;"_PRCRI(440.5),"2////"_$P(PRCD,"^",11)_";3////"_$P(PRCD,"^",12)_";15////"_$P(PRCD,"^",7)_";1////"_$P(PRCDO,"^",2))

 ... QUIT

 .. QUIT

 . QUIT

 D EDIT^PRC0B(.X,"440.8;^PRCH(440.8,;"_PRCRI(440.8),"3///NOW;5////"_PRCTTC)

 QUIT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCH7A   6642     printed  Mar 13, 2025@21:10:11                                                                                                                                                                                                      Page 2

PRCH7A    ;WISC/PLT-Receiver documents - ORA from ORACLE ; 07/01/98  3:37 PM

V         ;;5.1;IFCAP;**20,233**;Oct 20, 2000;Build 3

 +1       ;;Per VA Directive 6402, this routine should not be modified.

 +2       ;invalid entry

           QUIT

 +3       ;

 +4       ;invoked from task manager (see trin^prcosrv2)

 +5       ;convert message to file 440.6

 +6       ;PRCDA=ri of file 423.6 passed

CCR       ;Conversion CCR message from FMS MESSAGE SEVER routine PRCOSRV2

 +1        NEW PRCRI,PRCEDIT,PRCTY,PRCERR,PRCSEQ,PRCEX,A,B

 +2        SET PRCRI(423.6)=PRCDA

           SET PRCTY=""

 +3       ;copy ORACLE records to file 440.6

 +4        DO ICLOCK^PRC0B("^PRCH(440.8,")

 +5        DO COPY(PRCRI(423.6))

 +6        DO DCLOCK^PRC0B("^PRCH(440.8,")

 +7       ;

EXIT      ;delete ORACLE message in file 423.6

 +1        DO KILL^PRCOSRV3(PRCRI(423.6))

 +2        QUIT

 +3       ;

 +4       ;

COPY(PRCA) ;PRCA=ri of file 423.6

 +1        NEW PRCRI,PRCC,PRCD,PRCE,PRCT,PRCDUZ,PRCTTC,PRCDO,PRCEX,PRCSYS

 +2        NEW A,B,PRCX,X,Y

 +3        SET PRCSYS=1

 +4        SET X="NEW"

           SET X("DR")="1///NOW;6///T"

           DO ADD^PRC0B1(.X,.Y,"440.8;^PRCH(440.8,")

           if Y<1

               QUIT

 +5        SET PRCRI(440.8)=+Y

 +6        SET PRCC=$ORDER(^PRCF(423.6,PRCA,1,9999))

           SET PRCTTC=0

 +7        DO EDIT^PRC0B(.X,"440.8;^PRCH(440.8,;"_PRCRI(440.8),"2///NOW")

 +8        FOR

               SET PRCC=$ORDER(^PRCF(423.6,PRCA,1,PRCC))

               if 'PRCC

                   QUIT

               SET PRCD=^(PRCC,0)

               if PRCD["~"

                   Begin DoDot:1

 +9                    SET PRCT=$PIECE(PRCD,"^")

 +10                   SET PRCX=$PIECE(PRCD,"^",22)

 +11                   if PRCT="CCT"

                           Begin DoDot:2

 +12                           DO EDIT^PRC0B(.X,"440.8;^PRCH(440.8,;"_PRCRI(440.8),".01////"_$PIECE(PRCD,"^",3)_";4////"_$PIECE(PRCD,"^",2))

 +13                           QUIT

                           End DoDot:2

 +14                   if PRCT="CCR"

                           Begin DoDot:2

 +15                           SET PRCTTC=PRCTTC+1

                               SET PRCE="C"_$PIECE(PRCD,"^",2)_$PIECE(PRCD,"^",4)

                               SET PRCRI(440.6)=$ORDER(^PRCH(440.6,"B",PRCE,""))

 +16                           IF PRCRI(440.6)

                                   if $PIECE(^PRCH(440.6,PRCRI(440.6),0),"^",16)'="N"&($PIECE(^(0),"^",16)]"")

                                       QUIT

 +17                           IF 'PRCRI(440.6)

                                   SET X=PRCE

                                   DO ADD^PRC0B1(.X,.Y,"440.6;^PRCH(440.6,")

                                   if Y<1

                                       QUIT

                                   SET PRCRI(440.6)=+Y

 +18                           SET PRCDUZ=""

                               IF $PIECE(PRCD,"^",5)]""

                                   SET PRCRI(440.5)=$ORDER(^PRC(440.5,"B",$PIECE(PRCD,"^",5),""))

                                   IF PRCRI(440.5)

                                       SET PRCDUZ=$PIECE(^PRC(440.5,PRCRI(440.5),0),"^",8)

 +19                          SET X="1////"_$PIECE(PRCD,"^",3)_";2////"_$PIECE(PRCD,"^",4)_";3////"_$PIECE(PRCD,"^",5)_";4////"_$PIECE(PRCD,"^",6)_";7////"_$PIECE(PRCD,"^",9)_";9////"_$PIECE(PRCD,"^",11)_";12////"_...

                               ... $PIECE(PRCD,"^",14)_";13////"_$PIECE(PRCD,"^",15)_";14////"_$PIECE(PRCD,"^",21)

 +20                           SET X(1,440.6,1)="20////^S X=PRCX"_";21////"_$PIECE(PRCD,"^",16)_";22////"_$PIECE(PRCD,"^",17)_";23////"_$PIECE(PRCD,"^",18)_";24////"_$PIECE(PRCD,"^",19)_";25////"_$PIECE(PRCD,"^",20)_";16////"_PRCDUZ

 +21                           DO EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"")

 +22      ;edit date fields and status

 +23                           FOR A=7,10

                                   SET B=$PIECE(PRCD,"^",A)

                                   SET $PIECE(PRCD,"^",A)=$EXTRACT(B,3,4)_"/"_$EXTRACT(B,5,6)_"/"_$EXTRACT(B,1,2)

 +24                           SET B=$PIECE(PRCD,"^",8)

                               SET $PIECE(PRCD,"^",8)=$EXTRACT(B,1,2)_"/"_$EXTRACT(B,3,4)_"/"_$EXTRACT(B,5,6)

 +25                           if $PIECE(PRCD,"^",13)=""

                                   SET $PIECE(PRCD,"^",13)=$PIECE(PRCD,"^",12)

 +26                           SET A="15////N;8///"_$PIECE(PRCD,"^",10)_";6///"_$PIECE(PRCD,"^",8)_";5///"_$PIECE(PRCD,"^",7)_";10///"_$PIECE(PRCD,"^",12)_";11///"_$PIECE(PRCD,"^",13)

 +27                           DO EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),A)

 +28                           QUIT

                           End DoDot:2

 +29                   if PRCT="CC1"&$GET(PRCRI(440.6))

                           Begin DoDot:2

 +30      ;PRC*5.1*233

                               SET A="31////"_$TRANSLATE($PIECE(PRCD,"^",2),";","-")_";32////"_$PIECE(PRCD,"^",3)_";33////"_$PIECE(PRCD,"^",4)_";34////"_$PIECE(PRCD,"^",5)_";35////"_$PIECE(PRCD,"^",6)_";36////"_$TRANSLATE($PIECE(PRCD,"^",7,8),"^","")

 +31                           DO EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),A)

 +32                           SET PRCRI(440.6)=""

 +33                           QUIT

                           End DoDot:2

 +34      ;new purchase card data from AFS

 +35                   if PRCT="CCD"

                           Begin DoDot:2

 +36                           SET PRCTTC=PRCTTC+1

                               SET PRCEDIT=0

                               SET PRCE=$PIECE(PRCD,"^",2)

                               SET PRCRI(440.5)=$ORDER(^PRC(440.5,"B",PRCE,""))

 +37                           if PRCRI(440.5)

                                   SET PRCEDIT=1

 +38                           IF 'PRCRI(440.5)

                                   SET X=PRCE

                                   DO ADD^PRC0B1(.X,.Y,"440.5;^PRC(440.5,")

                                   if Y<1

                                       QUIT

                                   SET PRCRI(440.5)=+Y

 +39                           SET PRCE="51////"_$PIECE(PRCD,"^",3)_$$CCNR^PRCH0A($PIECE(PRCD,"^",3))

                               SET $PIECE(PRCE,";",2)="52////"_$PIECE(PRCD,"^",6)

 +40                           SET $PIECE(PRCE,";",3)="53////"_$PIECE(PRCD,"^",7)_$$ST^PRCH0A($PIECE(PRCD,"^",7))_$$STR^PRCH0A($PIECE(PRCD,"^",3),$PIECE(PRCD,"^",7))

 +41                           SET $PIECE(PRCE,";",4)="54////"_$PIECE(PRCD,"^",4)

 +42                           SET $PIECE(PRCE,";",5)="55////"_$PIECE(PRCD,"^",9)_$$FC^PRCH0A($PIECE(PRCD,"^",9))_$$FCR^PRCH0A($PIECE(PRCD,"^",3),$PIECE(PRCD,"^",9))

 +43                           SET $PIECE(PRCE,";",6)="56////"_$PIECE(PRCD,"^",10)_$$ACC^PRCH0A($PIECE(PRCD,"^",10))_$$ACCR^PRCH0A($PIECE(PRCD,"^",3),$PIECE(PRCD,"^",10))

 +44                           SET $PIECE(PRCE,";",7)="57////"_$PIECE(PRCD,"^",11)_$$CC^PRCH0A($PIECE(PRCD,"^",11))_$$CCR^PRCH0A($PIECE(PRCD,"^",3),$PIECE(PRCD,"^",11))

 +45                           SET $PIECE(PRCE(1,440.5,1),";",1)="58////"_$PIECE(PRCD,"^",12)_$$BOC^PRCH0A($PIECE(PRCD,"^",12),$PIECE(PRCD,"^",11))_$$BOCR^PRCH0A($PIECE(PRCD,"^",3),$PIECE(PRCD,"^",12))

 +46                           SET B=$PIECE(PRCD,"^",5)

                               SET B=$EXTRACT(B,5,6)_"/"_$EXTRACT(B,7,8)_"/"_$EXTRACT(B,1,4)

 +47                           SET A=$$FFVV^PRCH0A(440.5,16,B)

                               SET B=""

                               if '$PIECE(PRCD,"^",5)!'A

                                   SET B="*"

 +48                           SET $PIECE(PRCE(1,440.5,1),";",2)="59////"_$PIECE(PRCD,"^",5)_B

 +49                           SET $PIECE(PRCE(1,440.5,1),";",3)="60////"_$PIECE(PRCD,"^",2)_$$CCN^PRCH0A($PIECE(PRCD,"^",2))

 +50                           SET A=$$FFVV^PRCH0A(440.5,4,$PIECE(PRCD,"^",14))

                               SET B=""

                               if $PIECE(PRCD,"^",14)>$PIECE(PRCD,"^",15)!'A!'$PIECE(PRCD,"^",14)

                                   SET B="*"

                               SET $PIECE(PRCE(1,440.5,1),";",4)="61////"_$PIECE(PRCD,"^",14)_B

 +51                           SET A=$$FFVV^PRCH0A(440.5,5,$PIECE(PRCD,"^",15))

                               SET B=""

                               if $PIECE(PRCD,"^",15)<$PIECE(PRCD,"^",14)!'A!'$PIECE(PRCD,"^",15)

                                   SET B="*"

                               SET $PIECE(PRCE(1,440.5,1),";",5)="62////"_$PIECE(PRCD,"^",15)_B

 +52                           DO EDIT^PRC0B(.PRCE,"440.5;^PRC(440.5,;"_PRCRI(440.5),"")

                               KILL PRCE

 +53                           IF $PIECE(PRCD,"^",3)]""

                                   SET $PIECE(PRCD,"^",3)=$ORDER(^PRC(440.5,"B",$PIECE(PRCD,"^",3),0))

 +54                           SET PRCDO=""

                               IF $PIECE(PRCD,"^",3)

                                   SET PRCDO=$GET(^PRC(440.5,$PIECE(PRCD,"^",3),0))

                                   SET A="6////"_$PIECE(PRCDO,"^",7)_";7////"_$PIECE(PRCDO,"^",8)_";8////"_$PIECE(PRCDO,"^",9)_";9////"_$PIECE(PRCDO,"^",10)_";10////"_$PIECE(PRCDO,"^",11)

                                   Begin DoDot:3

 +55                                   DO EDIT^PRC0B(.X,"440.5;^PRC(440.5,;"_PRCRI(440.5),A)

 +56                                   QUIT

                                   End DoDot:3

 +57                           IF $PIECE(PRCD,"^",3)

                                   SET PRCRI=$PIECE(PRCD,"^",3)

                                   SET PRCRI(440.512)=0

FOR

                                       SET PRCRI(440.512)=$ORDER(^PRC(440.5,PRCRI,1,PRCRI(440.512)))

                                       if PRCRI(440.512)<1

                                           QUIT

                                       SET B=$GET(^(PRCRI(440.512),0))

                                       Begin DoDot:3

 +58                                       SET X=$PIECE(B,"^")

                                           IF X

                                               IF '$DATA(^PRC(440.5,PRCRI(440.5),1,+X))

                                                   DO ADD^PRC0B1(.X,.Y,"440.5;^PRC(440.5,;"_PRCRI(440.5)_";12~440.512;^PRC(440.5,"_PRCRI(440.5)_",1,",+X)

 +59                                       QUIT

                                       End DoDot:3

 +60                           SET A=$GET(^PRC(440.5,PRCRI(440.5),0))

                               SET B=$GET(^(50))

                               SET C=$GET(^(2))

                               SET D=1

                               SET PRCE=""

 +61                           SET D=1

                               IF $PIECE(A,"^",8)]""

                                   IF $PIECE(PRCD,"^",7)]""

                                       IF $PIECE(PRCDO,"^",2)]""

                                           SET $PIECE(PRCE,";",D)="63////"_$PIECE($PIECE(PRCDO,"^",2)," ")_$$UFCP^PRCH0A($PIECE(A,"^",8),$PIECE(PRCD,"^",7),$PIECE(PRCDO,"^",2))

                                           SET D=D+1

 +62                           if PRCE]""

                                   DO EDIT^PRC0B(.X,"440.5;^PRC(440.5,;"_PRCRI(440.5),PRCE)

 +63                           SET PRCEX=""

                               SET A=$GET(^PRC(440.5,PRCRI(440.5),50))

                               if A["*"

                                   SET PRCEX=PRCEX_"*"

                               if A["#"

                                   SET PRCEX=PRCEX_"#"

 +64                           DO EDIT^PRC0B(.X,"440.5;^PRC(440.5,;"_PRCRI(440.5),"14////"_$SELECT(PRCEX["*":"Y",1:"N")_";70////"_$SELECT(PRCEX]"":"E",1:"P")_";71////"_DT)

 +65                           IF PRCEX'["*"

                                   Begin DoDot:3

 +66                                   SET PRCE=$GET(^PRC(440.5,PRCRI(440.5),50))

 +67                                   DO EDIT^PRC0B(.X,"440.5;^PRC(440.5,;"_PRCRI(440.5),"4////"_$PIECE(PRCE,"^",11))

 +68                                   DO EDIT^PRC0B(.X,"440.5;^PRC(440.5,;"_PRCRI(440.5),"5////"_$PIECE(PRCE,"^",12))

 +69                                   SET B=$PIECE(PRCE,"^",9)

                                       DO EDIT^PRC0B(.X,"440.5;^PRC(440.5,;"_PRCRI(440.5),"16///"_$EXTRACT(B,5,6)_"/"_$EXTRACT(B,7,8)_"/"_$EXTRACT(B,1,4))

 +70                                   DO EDIT^PRC0B(.X,"440.5;^PRC(440.5,;"_PRCRI(440.5),"2////"_$PIECE(PRCD,"^",11)_";3////"_$PIECE(PRCD,"^",12)_";15////"_$PIECE(PRCD,"^",7)_";1////"_$PIECE(PRCDO,"^",2))

 +71                                   QUIT

                                   End DoDot:3

 +72                           QUIT

                           End DoDot:2

 +73                   QUIT

                   End DoDot:1

 +74       DO EDIT^PRC0B(.X,"440.8;^PRCH(440.8,;"_PRCRI(440.8),"3///NOW;5////"_PRCTTC)

 +75       QUIT

PRCH7A.m