PRCH7A ;WISC/PLT-Receiver documents - ORA from ORACLE ; 07/01/98 3:37 PM
V ;;5.1;IFCAP;**20**;Oct 20, 2000;Build 0
;Per VHA Directive 10-93-142, 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))
.. ;I $P(PRCD,"^",9)]"",$P(PRCD,"^",11)]"" QUIT:$TR($P(PRCD,"^",9,11),"^")'=$E(PRCE,2,999)
.. S A="31////"_$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),"^","")
.. 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 6707 printed Apr 09, 2024@21:14:58 Page 2
PRCH7A ;WISC/PLT-Receiver documents - ORA from ORACLE ; 07/01/98 3:37 PM
V ;;5.1;IFCAP;**20**;Oct 20, 2000;Build 0
+1 ;Per VHA Directive 10-93-142, 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 ;I $P(PRCD,"^",9)]"",$P(PRCD,"^",11)]"" QUIT:$TR($P(PRCD,"^",9,11),"^")'=$E(PRCE,2,999)
+31 SET A="31////"_$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),"^","")
+32 DO EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),A)
+33 SET PRCRI(440.6)=""
+34 QUIT
End DoDot:2
+35 ;new purchase card data from AFS
+36 if PRCT="CCD"
Begin DoDot:2
+37 SET PRCTTC=PRCTTC+1
SET PRCEDIT=0
SET PRCE=$PIECE(PRCD,"^",2)
SET PRCRI(440.5)=$ORDER(^PRC(440.5,"B",PRCE,""))
+38 if PRCRI(440.5)
SET PRCEDIT=1
+39 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
+40 SET PRCE="51////"_$PIECE(PRCD,"^",3)_$$CCNR^PRCH0A($PIECE(PRCD,"^",3))
SET $PIECE(PRCE,";",2)="52////"_$PIECE(PRCD,"^",6)
+41 SET $PIECE(PRCE,";",3)="53////"_$PIECE(PRCD,"^",7)_$$ST^PRCH0A($PIECE(PRCD,"^",7))_$$STR^PRCH0A($PIECE(PRCD,"^",3),$PIECE(PRCD,"^",7))
+42 SET $PIECE(PRCE,";",4)="54////"_$PIECE(PRCD,"^",4)
+43 SET $PIECE(PRCE,";",5)="55////"_$PIECE(PRCD,"^",9)_$$FC^PRCH0A($PIECE(PRCD,"^",9))_$$FCR^PRCH0A($PIECE(PRCD,"^",3),$PIECE(PRCD,"^",9))
+44 SET $PIECE(PRCE,";",6)="56////"_$PIECE(PRCD,"^",10)_$$ACC^PRCH0A($PIECE(PRCD,"^",10))_$$ACCR^PRCH0A($PIECE(PRCD,"^",3),$PIECE(PRCD,"^",10))
+45 SET $PIECE(PRCE,";",7)="57////"_$PIECE(PRCD,"^",11)_$$CC^PRCH0A($PIECE(PRCD,"^",11))_$$CCR^PRCH0A($PIECE(PRCD,"^",3),$PIECE(PRCD,"^",11))
+46 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))
+47 SET B=$PIECE(PRCD,"^",5)
SET B=$EXTRACT(B,5,6)_"/"_$EXTRACT(B,7,8)_"/"_$EXTRACT(B,1,4)
+48 SET A=$$FFVV^PRCH0A(440.5,16,B)
SET B=""
if '$PIECE(PRCD,"^",5)!'A
SET B="*"
+49 SET $PIECE(PRCE(1,440.5,1),";",2)="59////"_$PIECE(PRCD,"^",5)_B
+50 SET $PIECE(PRCE(1,440.5,1),";",3)="60////"_$PIECE(PRCD,"^",2)_$$CCN^PRCH0A($PIECE(PRCD,"^",2))
+51 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
+52 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
+53 DO EDIT^PRC0B(.PRCE,"440.5;^PRC(440.5,;"_PRCRI(440.5),"")
KILL PRCE
+54 IF $PIECE(PRCD,"^",3)]""
SET $PIECE(PRCD,"^",3)=$ORDER(^PRC(440.5,"B",$PIECE(PRCD,"^",3),0))
+55 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
+56 DO EDIT^PRC0B(.X,"440.5;^PRC(440.5,;"_PRCRI(440.5),A)
+57 QUIT
End DoDot:3
+58 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
+59 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)
+60 QUIT
End DoDot:3
+61 SET A=$GET(^PRC(440.5,PRCRI(440.5),0))
SET B=$GET(^(50))
SET C=$GET(^(2))
SET D=1
SET PRCE=""
+62 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
+63 if PRCE]""
DO EDIT^PRC0B(.X,"440.5;^PRC(440.5,;"_PRCRI(440.5),PRCE)
+64 SET PRCEX=""
SET A=$GET(^PRC(440.5,PRCRI(440.5),50))
if A["*"
SET PRCEX=PRCEX_"*"
if A["#"
SET PRCEX=PRCEX_"#"
+65 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)
+66 IF PRCEX'["*"
Begin DoDot:3
+67 SET PRCE=$GET(^PRC(440.5,PRCRI(440.5),50))
+68 DO EDIT^PRC0B(.X,"440.5;^PRC(440.5,;"_PRCRI(440.5),"4////"_$PIECE(PRCE,"^",11))
+69 DO EDIT^PRC0B(.X,"440.5;^PRC(440.5,;"_PRCRI(440.5),"5////"_$PIECE(PRCE,"^",12))
+70 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))
+71 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))
+72 QUIT
End DoDot:3
+73 QUIT
End DoDot:2
+74 QUIT
End DoDot:1
+75 DO EDIT^PRC0B(.X,"440.8;^PRCH(440.8,;"_PRCRI(440.8),"3///NOW;5////"_PRCTTC)
+76 QUIT
