Routine: PRCOEDIS

PRCOEDIS ;WISC/DJM-IFCAP X-REF ROUTINE FOR FILE 443.75 ; [8/31/98 1:24pm]

V ;;5.1;IFCAP;;Oct 20, 2000

 ;Per VHA Directive 10-93-142, this routine should not be modified.

S1 ; SET 'AC' X-REF -- CALLED FROM FIELD 1.  RFQ

 N N0

 S N0=$G(^PRC(443.75,DA,0))

 I $P(N0,U,4)="RFQ",$P(N0,U,6)]"",$P(N0,U,10)]"" S ^PRC(443.75,"AC",$P(N0,U,4),X,$P(N0,U,6),$P(N0,U,10),DA)=""

K1 ; KILL 'AC' X-REF -- CALLED FROM FIELD 1.  RFQ

 N N0

 S N0=$G(^PRC(443.75,DA,0))

 I $P(N0,U,4)="RFQ",$P(N0,U,6)]"",$P(N0,U,10)]"" K ^PRC(443.75,"AC",$P(N0,U,4),X,$P(N0,U,6),$P(N0,U,10),DA)

S2 ; SET 'AD' X-REF -- CALLED FROM FIELD 3.  RFQ

 ; ACTUALLY WILL SET 'AC' X-REF.

 N N0

 S N0=$G(^PRC(443.75,DA,0))

 I $P(N0,U,2)]"",$P(N0,U,6)]"",$P(N0,U,10)]"",X="RFQ" S ^PRC(443.75,"AC",X,$P(N0,U,2),$P(N0,U,6),$P(N0,U,10),DA)=""

K2 ; KILL 'AD' X-REF -- CALLED FROM FIELD 3.  RFQ

 ; ACTUALLY WILL KILL 'AC' X-REF.

 N N0

 S N0=$G(^PRC(443.75,DA,0))

 I $P(N0,U,2)]"",$P(N0,U,6)]"",$P(N0,U,10)]"",X="RFQ" K ^PRC(443.75,"AC",X,$P(N0,U,2),$P(N0,U,6),$P(N0,U,10),DA)

S3 ; SET 'AE' X-REF -- CALLED FROM FIELD 5.  RFQ

 ; ACTUALLY WILL SET 'AC' X-REF.

 N N0

 S N0=$G(^PRC(443.75,DA,0))

 I $P(N0,U,2)]"",$P(N0,U,4)="RFQ",$P(N0,U,10)]"" S ^PRC(443.75,"AC",$P(N0,U,4),$P(N0,U,2),X,$P(N0,U,10),DA)=""

K3 ; KILL 'AE' X-REF -- CALLED FROM FIELD 5.  RFQ

 ; ACTUALLY WILL KILL 'AC' X-REF.

 N N0

 S N0=$G(^PRC(443.75,DA,0))

 I $P(N0,U,2)]"",$P(N0,U,4)="RFQ",$P(N0,U,10)]"" K ^PRC(443.75,"AC",$P(N0,U,4),$P(N0,U,2),X,$P(N0,U,10),DA)

S4 ; SET 'AF' X-REF -- CALLED FROM FIELD 1.  TXT

 N N0

 S N0=$G(^PRC(443.75,DA,0))

 I $P(N0,U,3)]"",$P(N0,U,4)="TXT",$P(N0,U,6)]"" S ^PRC(443.75,"AF",$P(N0,U,4),X,$P(N0,U,6),$P(N0,U,3),DA)=""

K4 ; KILL 'AF' X-REF -- CALLED FROM FIELD 1.  TXT

 N N0

 S N0=$G(^PRC(443.75,DA,0))

 I $P(N0,U,3)]"",$P(N0,U,4)="TXT",$P(N0,U,6)]"" K ^PRC(443.75,"AF",$P(N0,U,4),X,$P(N0,U,6),$P(N0,U,3),DA)

S5 ; SET 'AG' X-REF -- CALLED FROM FIELD 2.  TXT

 ; ACTUALLY WILL SET 'AF' X-REF.

 N N0

 S N0=$G(^PRC(443.75,DA,0))

 I $P(N0,U,2)]"",$P(N0,U,4)="TXT",$P(N0,U,6)]"" S ^PRC(443.75,"AF",$P(N0,U,4),$P(N0,U,2),$P(N0,U,6),X,DA)=""

K5 ; KILL 'AG' X-REF -- CALLED FROM FIELD 2.  TXT

 ; ACTUALLY WILL KILL 'AF' X-REF.

 N N0

 S N0=$G(^PRC(443.75,DA,0))

 I $P(N0,U,2)]"",$P(N0,U,4)="TXT",$P(N0,U,6)]"" K ^PRC(443.75,"AF",$P(N0,U,4),$P(N0,U,2),$P(N0,U,6),X,DA)

S6 ; SET 'AH' X-REF -- CALLED FROM FIELD 3.  TXT

 ; ACTUALLY WILL SET 'AF' X-REF.

 N N0

 S N0=$G(^PRC(443.75,DA,0))

 I $P(N0,U,2)]"",$P(N0,U,3)]"",$P(N0,U,6)]"",X="TXT" S ^PRC(443.75,"AF",X,$P(N0,U,2),$P(N0,U,6),$P(N0,U,3),DA)=""

K6 ; KILL 'AH' X-REF -- CALLED FROM FIELD 3.  TXT

 ; ACTUALLY WILL KILL 'AF' X-REF.

 N N0

 S N0=$G(^PRC(443.75,DA,0))

 I $P(N0,U,2)]"",$P(N0,U,3)]"",$P(N0,U,6)]"",X="TXT" K ^PRC(443.75,"AF",X,$P(N0,U,2),$P(N0,U,6),$P(N0,U,3),DA)

S7 ; SET 'AI' X-REF -- CALLED FROM FIELD 5.  TXT

 ; ACTUALLY WILL SET 'AF' X-REF.

 N N0

 S N0=$G(^PRC(443.75,DA,0))

 I $P(N0,U,2)]"",$P(N0,U,3)]"",$P(N0,U,4)="TXT" S ^PRC(443.75,"AF",$P(N0,U,4),$P(N0,U,2),X,$P(N0,U,3),DA)=""

K7 ; KILL 'AI' X-REF -- CALLED FROM FIELD 5.  TXT

 ; ACTUALLY WILL KILL 'AF' X-REF.

 N N0

 S N0=$G(^PRC(443.75,DA,0))

 I $P(N0,U,2)]"",$P(N0,U,3)]"",$P(N0,U,4)="TXT" K ^PRC(443.75,"AF",$P(N0,U,4),$P(N0,U,2),X,$P(N0,U,3),X,DA)

S8 ; SET 'AN' X-REF -- CALLED FROM FIELD 6.5.  RFQ

 ; ACTUALLY WILL SET 'AC' X-REF.

 N N0

 S N0=$G(^PRC(443.75,DA,0))

 I $P(N0,U,2)]"",$P(N0,U,4)="RFQ",$P(N0,U,6)]"" S ^PRC(443.75,"AC",$P(N0,U,4),$P(N0,U,2),$P(N0,U,6),X,DA)=""

K8 ; KILL 'AN' X-REF -- CALLED FROM FIELD 6.5.  RFQ

 ; ACTUALLY WILL KILL 'AC' X-REF.

 N N0

 S N0=$G(^PRC(443.75,DA,0))

 I $P(N0,U,2)]"",$P(N0,U,4)="RFQ",$P(N0,U,6)]"" K ^PRC(443.75,"AC",$P(N0,U,4),$P(N0,U,2),$P(N0,U,6),X,DA)

S9 ; SET 'AO' X-REF -- CALLED FROM FIELD 1.  PHA

 N N0

 S N0=$G(^PRC(443.75,DA,0))

 I $P(N0,U,4)="PHA",$P(N0,U,6)]"" S ^PRC(443.75,"AO",$P(N0,U,4),X,$P(N0,U,6),DA)=""

K9 ; KILL 'AO' X-REF -- CALLED FROM FIELD 1.  PHA

 N N0

 S N0=$G(^PRC(443.75,DA,0))

 I $P(N0,U,4)="PHA",$P(N0,U,6)]"" K ^PRC(443.75,"AO",$P(N0,U,4),X,$P(N0,U,6),DA)

S10 ; SET 'AP' X-REF -- CALLED FROM FIELD 3.  PHA

 ; ACTUALLY WILL SET 'AO' X-REF.

 N N0

 S N0=$G(^PRC(443.75,DA,0))

 I X="PHA",$P(N0,U,2)]"",$P(N0,U,6)]"" S ^PRC(443.75,"AO",X,$P(N0,U,2),$P(N0,U,6),DA)=""

K10 ; KILL 'AP' X-REF -- CALLED FROM FIELD 3.  PHA

 ; ACTUALLY WILL KILL 'AO' X-REF.

 N N0

 S N0=$G(^PRC(443.75,DA,0))

 I X="PHA",$P(N0,U,2)]"",$P(N0,U,6)]"" K ^PRC(443.75,"AO",X,$P(N0,U,2),$P(N0,U,6),DA)

S11 ; SET 'AQ' X-REF -- CALLED FROM FIELD 5.  PHA

 ; ACTUALLY WILL SET 'AO' X-REF.

 N N0

 S N0=$G(^PRC(443.75,DA,0))

 I $P(N0,U,2)]"",$P(N0,U,4)="PHA" S ^PRC(443.75,"AO",$P(N0,U,4),$P(N0,U,2),X,DA)=""

K11 ; KILL 'AQ' X-REF -- CALLED FROM FIELD 5.  PHA

 ; ACTUALLY WILL KILL 'AO' X-REF.

 N N0

 S N0=$G(^PRC(443.75,DA,0))

 I $P(N0,U,2)]"",$P(N0,U,4)="PHA" K ^PRC(443.75,"AO",$P(N0,U,4),$P(N0,U,2),X,DA)

S12 ; SET 'AL' X-REF FOR ALL ACCEPTED OR REJECTED TRANSACTIONS.

 ; CALLED FROM FIELD 10.

 ; SEE IF FIELD 24 IS SET.  IF SO DON'T SET THIS X-REF.

 S Z0=$G(^PRC(443.75,DA,1))

 S Z1=$P(Z0,U)

 S Z17=$P(Z0,U,17)

 I Z1]""&(Z17=2) D

 .  S ^PRC(443.75,"AL",Z17,Z1,+$E(X,1,30),DA)=""

 .  ;

 .  ; NOW KILL 'AJ' X-REF FOR THIS RECORD.

 .  ;

 .  S Z0=$G(^PRC(443.75,DA,0))

 .  S Z4=$P(Z0,U,4)

 .  S Z7=$P(Z0,U,7)

 .  ;

 .  ; THE 1 AFTER "AJ" IS THE LEVEL.

 .  ;

 .  K:Z4]""&(Z7>0) ^PRC(443.75,"AJ",1,Z4,+$E(Z7,1,30),DA)

 .  Q

 K Z0,Z1,Z4,Z7,Z17

K12 ; KILL 'AL' X-REF FOR ALL ACCEPTED OR REJECTED TRANSACTIONS.

 ; CALLED FROM FIELD 10.

 S Z0=$G(^PRC(443.75,DA,1))

 S Z17=$P(Z0,U,17)

 S Z1=$P(Z0,U)

 I Z17=2&(Z1]"") D

 .  K ^PRC(443.75,"AL",2,Z1,+$E(X,1,30),DA)

 .  ;

 .  ; NOW LETS RESTORE 'AJ' X-REF FOR THIS RECORD.

 .  ;

 .  S Z0=$G(^PRC(443.75,DA,0))

 .  S Z4=$P(Z0,U,4)

 .  S Z7=$P(Z0,U,7)

 .  ;

 .  ; THE 1 AFTER "AJ" IS THE LEVEL.

 .  ;

 .  S:Z4]""&(Z7>0) ^PRC(443.75,"AJ",1,Z4,+$E(Z7,1,30),DA)=""

 .  Q

 K Z0,Z1,Z4,Z7

S13 ; SET 'AM' X-REF FOR ALL POA TRANSACTIONS.

 ; CALLED FROM FIELD 24.

 S Z0=$G(^PRC(443.75,DA,1))

 S Z1=$P(Z0,U)

 S Z2=$P(Z0,U,2)

 S Z15=$P(Z0,U,15)

 S Z17=$P(Z0,U,17)

 I Z17=3&(Z15]"") D

 .  S ^PRC(443.75,"AM",3,Z15,+$E(X,1,30),DA)=""

 .  ;

 .  ; NOW KILL 'AL' X-REF FOR THIS RECORD.

 .  ; THE 2 AFTER "AL" IS THE LEVEL.

 .  ;

 .  K:Z1]""&(Z2>0) ^PRC(443.75,"AL",2,Z1,+$E(Z2,1,30),DA)

 .  Q

 K Z0,Z1,Z2,Z15

K13 ; KILL 'AM' X-REF FOR ALL POA TRANSACTIONS.

 ; CALLED FROM FIELD 24.

 S Z0=$G(^PRC(443.75,DA,1))

 S Z1=$P(Z0,U)

 S Z2=$P(Z0,U,2)

 S Z15=$P(Z0,U,15)

 S Z17=$P(Z0,U,17)

 I Z15]""&(Z17=3) D

 .  K ^PRC(443.75,"AM",Z17,Z15,+$E(X,1,30),DA)

 .  ;

 .  ; NOW SET 'AL' X-REF FOR THIS RECORD.

 .  ; THE 2 AFTER "AL" IS THE LEVEL.

 .  ;

 .  S:Z1]""&(Z2>0) ^PRC(443.75,"AL",2,Z1,+$E(Z2,1,30),DA)=""

 .  Q

 K Z0,Z1,Z2,Z15

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCOEDIS   7051     printed  Mar 13, 2025@21:16:40                                                                                                                                                                                                    Page 2

PRCOEDIS  ;WISC/DJM-IFCAP X-REF ROUTINE FOR FILE 443.75 ; [8/31/98 1:24pm]

V         ;;5.1;IFCAP;;Oct 20, 2000

 +1       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +2       ;

S1        ; SET 'AC' X-REF -- CALLED FROM FIELD 1.  RFQ

 +1        NEW N0

 +2        SET N0=$GET(^PRC(443.75,DA,0))

 +3        IF $PIECE(N0,U,4)="RFQ"

               IF $PIECE(N0,U,6)]""

                   IF $PIECE(N0,U,10)]""

                       SET ^PRC(443.75,"AC",$PIECE(N0,U,4),X,$PIECE(N0,U,6),$PIECE(N0,U,10),DA)=""

 +4        QUIT

 +5       ;

K1        ; KILL 'AC' X-REF -- CALLED FROM FIELD 1.  RFQ

 +1        NEW N0

 +2        SET N0=$GET(^PRC(443.75,DA,0))

 +3        IF $PIECE(N0,U,4)="RFQ"

               IF $PIECE(N0,U,6)]""

                   IF $PIECE(N0,U,10)]""

                       KILL ^PRC(443.75,"AC",$PIECE(N0,U,4),X,$PIECE(N0,U,6),$PIECE(N0,U,10),DA)

 +4        QUIT

 +5       ;

S2        ; SET 'AD' X-REF -- CALLED FROM FIELD 3.  RFQ

 +1       ; ACTUALLY WILL SET 'AC' X-REF.

 +2        NEW N0

 +3        SET N0=$GET(^PRC(443.75,DA,0))

 +4        IF $PIECE(N0,U,2)]""

               IF $PIECE(N0,U,6)]""

                   IF $PIECE(N0,U,10)]""

                       IF X="RFQ"

                           SET ^PRC(443.75,"AC",X,$PIECE(N0,U,2),$PIECE(N0,U,6),$PIECE(N0,U,10),DA)=""

 +5        QUIT

 +6       ;

K2        ; KILL 'AD' X-REF -- CALLED FROM FIELD 3.  RFQ

 +1       ; ACTUALLY WILL KILL 'AC' X-REF.

 +2        NEW N0

 +3        SET N0=$GET(^PRC(443.75,DA,0))

 +4        IF $PIECE(N0,U,2)]""

               IF $PIECE(N0,U,6)]""

                   IF $PIECE(N0,U,10)]""

                       IF X="RFQ"

                           KILL ^PRC(443.75,"AC",X,$PIECE(N0,U,2),$PIECE(N0,U,6),$PIECE(N0,U,10),DA)

 +5        QUIT

 +6       ;

S3        ; SET 'AE' X-REF -- CALLED FROM FIELD 5.  RFQ

 +1       ; ACTUALLY WILL SET 'AC' X-REF.

 +2        NEW N0

 +3        SET N0=$GET(^PRC(443.75,DA,0))

 +4        IF $PIECE(N0,U,2)]""

               IF $PIECE(N0,U,4)="RFQ"

                   IF $PIECE(N0,U,10)]""

                       SET ^PRC(443.75,"AC",$PIECE(N0,U,4),$PIECE(N0,U,2),X,$PIECE(N0,U,10),DA)=""

 +5        QUIT

 +6       ;

K3        ; KILL 'AE' X-REF -- CALLED FROM FIELD 5.  RFQ

 +1       ; ACTUALLY WILL KILL 'AC' X-REF.

 +2        NEW N0

 +3        SET N0=$GET(^PRC(443.75,DA,0))

 +4        IF $PIECE(N0,U,2)]""

               IF $PIECE(N0,U,4)="RFQ"

                   IF $PIECE(N0,U,10)]""

                       KILL ^PRC(443.75,"AC",$PIECE(N0,U,4),$PIECE(N0,U,2),X,$PIECE(N0,U,10),DA)

 +5        QUIT

 +6       ;

S4        ; SET 'AF' X-REF -- CALLED FROM FIELD 1.  TXT

 +1        NEW N0

 +2        SET N0=$GET(^PRC(443.75,DA,0))

 +3        IF $PIECE(N0,U,3)]""

               IF $PIECE(N0,U,4)="TXT"

                   IF $PIECE(N0,U,6)]""

                       SET ^PRC(443.75,"AF",$PIECE(N0,U,4),X,$PIECE(N0,U,6),$PIECE(N0,U,3),DA)=""

 +4        QUIT

 +5       ;

K4        ; KILL 'AF' X-REF -- CALLED FROM FIELD 1.  TXT

 +1        NEW N0

 +2        SET N0=$GET(^PRC(443.75,DA,0))

 +3        IF $PIECE(N0,U,3)]""

               IF $PIECE(N0,U,4)="TXT"

                   IF $PIECE(N0,U,6)]""

                       KILL ^PRC(443.75,"AF",$PIECE(N0,U,4),X,$PIECE(N0,U,6),$PIECE(N0,U,3),DA)

 +4        QUIT

 +5       ;

S5        ; SET 'AG' X-REF -- CALLED FROM FIELD 2.  TXT

 +1       ; ACTUALLY WILL SET 'AF' X-REF.

 +2        NEW N0

 +3        SET N0=$GET(^PRC(443.75,DA,0))

 +4        IF $PIECE(N0,U,2)]""

               IF $PIECE(N0,U,4)="TXT"

                   IF $PIECE(N0,U,6)]""

                       SET ^PRC(443.75,"AF",$PIECE(N0,U,4),$PIECE(N0,U,2),$PIECE(N0,U,6),X,DA)=""

 +5        QUIT

 +6       ;

K5        ; KILL 'AG' X-REF -- CALLED FROM FIELD 2.  TXT

 +1       ; ACTUALLY WILL KILL 'AF' X-REF.

 +2        NEW N0

 +3        SET N0=$GET(^PRC(443.75,DA,0))

 +4        IF $PIECE(N0,U,2)]""

               IF $PIECE(N0,U,4)="TXT"

                   IF $PIECE(N0,U,6)]""

                       KILL ^PRC(443.75,"AF",$PIECE(N0,U,4),$PIECE(N0,U,2),$PIECE(N0,U,6),X,DA)

 +5        QUIT

 +6       ;

S6        ; SET 'AH' X-REF -- CALLED FROM FIELD 3.  TXT

 +1       ; ACTUALLY WILL SET 'AF' X-REF.

 +2        NEW N0

 +3        SET N0=$GET(^PRC(443.75,DA,0))

 +4        IF $PIECE(N0,U,2)]""

               IF $PIECE(N0,U,3)]""

                   IF $PIECE(N0,U,6)]""

                       IF X="TXT"

                           SET ^PRC(443.75,"AF",X,$PIECE(N0,U,2),$PIECE(N0,U,6),$PIECE(N0,U,3),DA)=""

 +5        QUIT

 +6       ;

K6        ; KILL 'AH' X-REF -- CALLED FROM FIELD 3.  TXT

 +1       ; ACTUALLY WILL KILL 'AF' X-REF.

 +2        NEW N0

 +3        SET N0=$GET(^PRC(443.75,DA,0))

 +4        IF $PIECE(N0,U,2)]""

               IF $PIECE(N0,U,3)]""

                   IF $PIECE(N0,U,6)]""

                       IF X="TXT"

                           KILL ^PRC(443.75,"AF",X,$PIECE(N0,U,2),$PIECE(N0,U,6),$PIECE(N0,U,3),DA)

 +5        QUIT

 +6       ;

S7        ; SET 'AI' X-REF -- CALLED FROM FIELD 5.  TXT

 +1       ; ACTUALLY WILL SET 'AF' X-REF.

 +2        NEW N0

 +3        SET N0=$GET(^PRC(443.75,DA,0))

 +4        IF $PIECE(N0,U,2)]""

               IF $PIECE(N0,U,3)]""

                   IF $PIECE(N0,U,4)="TXT"

                       SET ^PRC(443.75,"AF",$PIECE(N0,U,4),$PIECE(N0,U,2),X,$PIECE(N0,U,3),DA)=""

 +5        QUIT

 +6       ;

K7        ; KILL 'AI' X-REF -- CALLED FROM FIELD 5.  TXT

 +1       ; ACTUALLY WILL KILL 'AF' X-REF.

 +2        NEW N0

 +3        SET N0=$GET(^PRC(443.75,DA,0))

 +4        IF $PIECE(N0,U,2)]""

               IF $PIECE(N0,U,3)]""

                   IF $PIECE(N0,U,4)="TXT"

                       KILL ^PRC(443.75,"AF",$PIECE(N0,U,4),$PIECE(N0,U,2),X,$PIECE(N0,U,3),X,DA)

 +5        QUIT

 +6       ;

S8        ; SET 'AN' X-REF -- CALLED FROM FIELD 6.5.  RFQ

 +1       ; ACTUALLY WILL SET 'AC' X-REF.

 +2        NEW N0

 +3        SET N0=$GET(^PRC(443.75,DA,0))

 +4        IF $PIECE(N0,U,2)]""

               IF $PIECE(N0,U,4)="RFQ"

                   IF $PIECE(N0,U,6)]""

                       SET ^PRC(443.75,"AC",$PIECE(N0,U,4),$PIECE(N0,U,2),$PIECE(N0,U,6),X,DA)=""

 +5        QUIT

 +6       ;

K8        ; KILL 'AN' X-REF -- CALLED FROM FIELD 6.5.  RFQ

 +1       ; ACTUALLY WILL KILL 'AC' X-REF.

 +2        NEW N0

 +3        SET N0=$GET(^PRC(443.75,DA,0))

 +4        IF $PIECE(N0,U,2)]""

               IF $PIECE(N0,U,4)="RFQ"

                   IF $PIECE(N0,U,6)]""

                       KILL ^PRC(443.75,"AC",$PIECE(N0,U,4),$PIECE(N0,U,2),$PIECE(N0,U,6),X,DA)

 +5        QUIT

 +6       ;

S9        ; SET 'AO' X-REF -- CALLED FROM FIELD 1.  PHA

 +1        NEW N0

 +2        SET N0=$GET(^PRC(443.75,DA,0))

 +3        IF $PIECE(N0,U,4)="PHA"

               IF $PIECE(N0,U,6)]""

                   SET ^PRC(443.75,"AO",$PIECE(N0,U,4),X,$PIECE(N0,U,6),DA)=""

 +4        QUIT

 +5       ;

K9        ; KILL 'AO' X-REF -- CALLED FROM FIELD 1.  PHA

 +1        NEW N0

 +2        SET N0=$GET(^PRC(443.75,DA,0))

 +3        IF $PIECE(N0,U,4)="PHA"

               IF $PIECE(N0,U,6)]""

                   KILL ^PRC(443.75,"AO",$PIECE(N0,U,4),X,$PIECE(N0,U,6),DA)

 +4        QUIT

 +5       ;

S10       ; SET 'AP' X-REF -- CALLED FROM FIELD 3.  PHA

 +1       ; ACTUALLY WILL SET 'AO' X-REF.

 +2        NEW N0

 +3        SET N0=$GET(^PRC(443.75,DA,0))

 +4        IF X="PHA"

               IF $PIECE(N0,U,2)]""

                   IF $PIECE(N0,U,6)]""

                       SET ^PRC(443.75,"AO",X,$PIECE(N0,U,2),$PIECE(N0,U,6),DA)=""

 +5        QUIT

 +6       ;

K10       ; KILL 'AP' X-REF -- CALLED FROM FIELD 3.  PHA

 +1       ; ACTUALLY WILL KILL 'AO' X-REF.

 +2        NEW N0

 +3        SET N0=$GET(^PRC(443.75,DA,0))

 +4        IF X="PHA"

               IF $PIECE(N0,U,2)]""

                   IF $PIECE(N0,U,6)]""

                       KILL ^PRC(443.75,"AO",X,$PIECE(N0,U,2),$PIECE(N0,U,6),DA)

 +5        QUIT

 +6       ;

S11       ; SET 'AQ' X-REF -- CALLED FROM FIELD 5.  PHA

 +1       ; ACTUALLY WILL SET 'AO' X-REF.

 +2        NEW N0

 +3        SET N0=$GET(^PRC(443.75,DA,0))

 +4        IF $PIECE(N0,U,2)]""

               IF $PIECE(N0,U,4)="PHA"

                   SET ^PRC(443.75,"AO",$PIECE(N0,U,4),$PIECE(N0,U,2),X,DA)=""

 +5        QUIT

 +6       ;

K11       ; KILL 'AQ' X-REF -- CALLED FROM FIELD 5.  PHA

 +1       ; ACTUALLY WILL KILL 'AO' X-REF.

 +2        NEW N0

 +3        SET N0=$GET(^PRC(443.75,DA,0))

 +4        IF $PIECE(N0,U,2)]""

               IF $PIECE(N0,U,4)="PHA"

                   KILL ^PRC(443.75,"AO",$PIECE(N0,U,4),$PIECE(N0,U,2),X,DA)

 +5        QUIT

 +6       ;

S12       ; SET 'AL' X-REF FOR ALL ACCEPTED OR REJECTED TRANSACTIONS.

 +1       ; CALLED FROM FIELD 10.

 +2       ;

 +3       ; SEE IF FIELD 24 IS SET.  IF SO DON'T SET THIS X-REF.

 +4       ;

 +5        SET Z0=$GET(^PRC(443.75,DA,1))

 +6        SET Z1=$PIECE(Z0,U)

 +7        SET Z17=$PIECE(Z0,U,17)

 +8        IF Z1]""&(Z17=2)

               Begin DoDot:1

 +9                SET ^PRC(443.75,"AL",Z17,Z1,+$EXTRACT(X,1,30),DA)=""

 +10      ;

 +11      ; NOW KILL 'AJ' X-REF FOR THIS RECORD.

 +12      ;

 +13               SET Z0=$GET(^PRC(443.75,DA,0))

 +14               SET Z4=$PIECE(Z0,U,4)

 +15               SET Z7=$PIECE(Z0,U,7)

 +16      ;

 +17      ; THE 1 AFTER "AJ" IS THE LEVEL.

 +18      ;

 +19               if Z4]""&(Z7>0)

                       KILL ^PRC(443.75,"AJ",1,Z4,+$EXTRACT(Z7,1,30),DA)

 +20               QUIT

               End DoDot:1

 +21       KILL Z0,Z1,Z4,Z7,Z17

 +22       QUIT

 +23      ;

K12       ; KILL 'AL' X-REF FOR ALL ACCEPTED OR REJECTED TRANSACTIONS.

 +1       ; CALLED FROM FIELD 10.

 +2       ;

 +3        SET Z0=$GET(^PRC(443.75,DA,1))

 +4        SET Z17=$PIECE(Z0,U,17)

 +5        SET Z1=$PIECE(Z0,U)

 +6        IF Z17=2&(Z1]"")

               Begin DoDot:1

 +7                KILL ^PRC(443.75,"AL",2,Z1,+$EXTRACT(X,1,30),DA)

 +8       ;

 +9       ; NOW LETS RESTORE 'AJ' X-REF FOR THIS RECORD.

 +10      ;

 +11               SET Z0=$GET(^PRC(443.75,DA,0))

 +12               SET Z4=$PIECE(Z0,U,4)

 +13               SET Z7=$PIECE(Z0,U,7)

 +14      ;

 +15      ; THE 1 AFTER "AJ" IS THE LEVEL.

 +16      ;

 +17               if Z4]""&(Z7>0)

                       SET ^PRC(443.75,"AJ",1,Z4,+$EXTRACT(Z7,1,30),DA)=""

 +18               QUIT

               End DoDot:1

 +19       KILL Z0,Z1,Z4,Z7

 +20       QUIT

 +21      ;

S13       ; SET 'AM' X-REF FOR ALL POA TRANSACTIONS.

 +1       ; CALLED FROM FIELD 24.

 +2       ;

 +3        SET Z0=$GET(^PRC(443.75,DA,1))

 +4        SET Z1=$PIECE(Z0,U)

 +5        SET Z2=$PIECE(Z0,U,2)

 +6        SET Z15=$PIECE(Z0,U,15)

 +7        SET Z17=$PIECE(Z0,U,17)

 +8        IF Z17=3&(Z15]"")

               Begin DoDot:1

 +9                SET ^PRC(443.75,"AM",3,Z15,+$EXTRACT(X,1,30),DA)=""

 +10      ;

 +11      ; NOW KILL 'AL' X-REF FOR THIS RECORD.

 +12      ; THE 2 AFTER "AL" IS THE LEVEL.

 +13      ;

 +14               if Z1]""&(Z2>0)

                       KILL ^PRC(443.75,"AL",2,Z1,+$EXTRACT(Z2,1,30),DA)

 +15               QUIT

               End DoDot:1

 +16       KILL Z0,Z1,Z2,Z15

 +17       QUIT

 +18      ;

K13       ; KILL 'AM' X-REF FOR ALL POA TRANSACTIONS.

 +1       ; CALLED FROM FIELD 24.

 +2       ;

 +3        SET Z0=$GET(^PRC(443.75,DA,1))

 +4        SET Z1=$PIECE(Z0,U)

 +5        SET Z2=$PIECE(Z0,U,2)

 +6        SET Z15=$PIECE(Z0,U,15)

 +7        SET Z17=$PIECE(Z0,U,17)

 +8        IF Z15]""&(Z17=3)

               Begin DoDot:1

 +9                KILL ^PRC(443.75,"AM",Z17,Z15,+$EXTRACT(X,1,30),DA)

 +10      ;

 +11      ; NOW SET 'AL' X-REF FOR THIS RECORD.

 +12      ; THE 2 AFTER "AL" IS THE LEVEL.

 +13      ;

 +14               if Z1]""&(Z2>0)

                       SET ^PRC(443.75,"AL",2,Z1,+$EXTRACT(Z2,1,30),DA)=""

 +15               QUIT

               End DoDot:1

 +16       KILL Z0,Z1,Z2,Z15

 +17       QUIT

PRCOEDIS.m