PRCOEDI2.m

PRCOEDI2 ;WISC/DJM-IFCAP X-REF ROUTINE FOR FILE 443.75 CONTINUED ; [8/31/98 11:55am]

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

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

 ;

S1 ; SET 'AL1' X-REF FOR ALL ACCEPTED OR REJECTED TRANSACTIONS BY

 ; SENDER.

 ; CALLED FROM FIELD 10.

 ;

 ; SEE IF FIELD 5.5 IS SET.  IF EMPTY DON'T SET THIS X-REF.

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

 ;

 S SENDER=$P($G(^PRC(443.75,DA,0)),U,11)

 I SENDER="" K SENDER Q

 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,"AL1",Z17,SENDER,Z1,+$E(X,1,30),DA)=""

 .  ;

 .  ; NOW KILL 'AJ1' 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 "AJ1" IS THE LEVEL.

 .  ;

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

 .  Q

 K Z0,Z1,Z4,Z7,Z17,SENDER

 Q

 ;

K1 ; KILL 'AL1' X-REF FOR ALL ACCEPTED OR REJECTED TRANSACTIONS.

 ; CALLED FROM FIELD 10.

 ;

 S SENDER=$P($G(^PRC(443.75,DA,0)),U,11)

 I SENDER="" K SENDER Q

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

 S Z1=$P(Z0,U)

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

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

 .  K ^PRC(443.75,"AL1",Z17,SENDER,Z1,+$E(X,1,30),DA)

 .  ;

 .  ; NOW LETS RESTORE 'AJ1' 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 IN THE NEXT '^' PIECE AFTER "AJ1" IS THE LEVEL.

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

 .  Q

 K Z0,Z1,Z4,Z7,Z17,SENDER

 Q

 ;

S2 ; SET 'AM1' X-REF FOR ALL POA TRANSACTIONS.

 ; CALLED FROM FIELD 24.

 ;

 S SENDER=$P($G(^PRC(443.75,DA,0)),U,11)

 I SENDER="" K SENDER Q

 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

 .  S ^PRC(443.75,"AM1",Z17,SENDER,Z15,+$E(X,1,30),DA)=""

 .  ;

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

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

 .  ;

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

 .  Q

 K Z0,Z1,Z2,Z15,Z17,SENDER

 Q

 ;

K2 ; KILL 'AM1' X-REF FOR ALL POA TRANSACTIONS.

 ; CALLED FROM FIELD 24.

 ;

 S SENDER=$P($G(^PRC(443.75,DA,0)),U,11)

 I SENDER="" K SENDER Q

 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,"AM1",Z17,SENDER,Z15,+$E(X,1,30),DA)

 .  ;

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

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

 .  ;

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

 .  Q

 K Z0,Z1,Z2,Z15,Z17,SENDER

 Q

 ;

S3 ; SET 'AJ1' X-REF FOR ALL ENTRIES WITHOUT ANY RESPONSE FROM AUSTIN.

 ; CALLED FROM FIELD 6.

 ;

 S SENDER=$P($G(^PRC(443.75,DA,0)),U,11)

 I SENDER="" K SENDER Q

 S Z0=$P($G(^PRC(443.75,DA,0)),U,4)

 S Z1=$P($G(^PRC(443.75,DA,1)),U,17)

 S:Z1=1&(Z0]"") ^PRC(443.75,"AJ1",Z1,SENDER,Z0,$E(X,1,30),DA)=""

 K Z0,Z1

 Q

 ;

K3 ; KILL 'AJ1' X-REF FOR ALL ENTRIES WITHOUT ANY RESPONSE FROM AUSTIN.

 ; CALLED FROM FIELD 6.

 ;

 S SENDER=$P($G(^PRC(443.75,DA,0)),U,11)

 I SENDER="" K SENDER Q

 S Z0=$P($G(^PRC(443.75,DA,0)),U,4)

 S Z1=$P($G(^PRC(443.75,DA,1)),U,17)

 K:Z1=1&(Z0]"") ^PRC(443.75,"AJ1",Z1,SENDER,Z0,$E(X,1,30),DA)

 K Z0,Z1

 Q

 ;

S4 ; SET 'AL1X9' X-REF -- CALLED FROM FIELD 9.  LEVEL 2

 ; ACTUALLY WILL SET 'AL1' X-REF.

 N Z0,Z03,Z055,Z1,Z110,Z125

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

 S Z055=$P(Z0,U,11)  ;FIELD 5.5

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

 S Z110=$P(Z1,U,2)  ;FIELD 10

 S Z125=$P(Z1,U,17)  ;FIELD 25

 I Z055>0&(Z110>0)&(Z125=2) D

 .  S ^PRC(443.75,"AL1",Z125,Z055,X,Z110,DA)=""

 .  ;

 .  ; WENT UP A LEVEL -- NEED TO REMOVE SENDER FROM LOWER LEVEL.

 .  ;

 .  S Z03=$P(Z0,U,4)  ;FIELD 3

 .  S Z0=$P(Z0,U,7)  ;FIELD 6

 .  K:Z03]""&(Z055>0)&(Z0>0) ^PRC(443.75,"AJ1",1,Z055,Z03,Z0,DA)

 .  Q

 Q

 ;

K4 ; KILL 'AL1X9' X-REF -- CALLED FROM FIELD 9.  LEVEL 2

 ; ACTUALLY WILL KILL 'AL1' X-REF.

 N Z0,Z03,Z055,Z1,Z110,Z125

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

 S Z055=$P(Z0,U,11)  ;FIELD 5.5

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

 S Z110=$P(Z1,U,2)  ;FIELD 10

 S Z125=$P(Z1,U,17)  ;FIELD 25

 I Z055>0&(Z110>0)&(Z125=2) D

 .  K ^PRC(443.75,"AL1",Z125,Z055,X,Z110,DA)

 .  ;

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

 .  ;

 .  S Z03=$P(Z0,U,4)  ;FIELD 3

 .  S Z0=$P(Z0,U,7)  ;FIELD 6

 .  S:Z03]""&(Z055>0)&(Z0>0) ^PRC(443.75,"AJ1",1,Z055,Z03,Z0,DA)=""

 Q

 ;

S5 ; SET 'AMX23' X-REF -- CALLED FROM FIELD 23.  LEVEL 3

 ; ACTUALLY WILL SET 'AM' X-REF.

 N Z1,Z19,Z110,Z124,Z125

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

 S Z124=$P(Z1,U,16)  ;FIELD 24

 S Z125=$P(Z1,U,17)  ;FIELD 25

 I Z124>0&(Z125=3) D

 .  S ^PRC(443.75,"AM",Z125,X,Z124,DA)=""

 .  ;

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

 .  ;THE 2 AFTER "AL" IS FIELD 25, LEVEL 2.

 .  ;

 .  S Z19=$P(Z1,U)  ;FIELD 9

 .  S Z110=$P(Z1,U,2)  ;FIELD 10

 .  K:Z19]""&(Z110>0) ^PRC(443.75,"AL",2,Z19,Z110,DA)

 .  Q

 Q

 ;

K5 ; KILL 'AMX23' X-REF -- CALLED FROM FIELD 23.  LEVEL 3

 ; ACTUALLY WILL KILL 'AM' X-REF.

 N Z1,Z19,Z110,Z124,Z125

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

 S Z124=$P(Z1,U,16)  ;FIELD 24

 S Z125=$P(Z1,U,17)  ;FIELD 25

 I Z124>0&(Z125=3) D

 .  K ^PRC(443.75,"AM",Z125,X,Z124,DA)

 .  ;

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

 .  ;

 .  S Z19=$P(Z1,U)  ;FIELD 9

 .  S Z110=$P(Z1,U,2)  ;FIELD 10

 .  S:Z19]""&(Z110>0) ^PRC(443.75,"AL",2,Z19,Z110,DA)=""

 .  Q

 Q

 ;

S6 ; SET 'AM1X23' X-REF -- CALLED FROM FIELD 23.  LEVEL 3

 ; ACTUALLY WILL SET 'AM1' X-REF.

 N Z0,Z1,Z19,Z110,Z124,Z125

 S Z0=$P($G(^PRC(443.75,DA,0)),U,11)  ;FIELD 5.5

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

 S Z124=$P(Z1,U,16)  ;FIELD 24

 S Z125=$P(Z1,U,17)  ;FIELD 25

 I Z0>0&(Z124>0)&(Z125=3) D

 .  S ^PRC(443.75,"AM1",Z125,Z0,X,Z124,DA)=""

 .  ;

 .  ; WENT UP A LEVEL -- NEED TO REMOVE SENDER FROM LOWER LEVEL.

 .  ;

 .  S Z19=$P(Z1,U)  ;FIELD 9

 .  S Z110=$P(Z1,U,2)  ;FIELD 10

 .  K:Z0>0&(Z19]"")&(Z110>0) ^PRC(443.75,"AL1",2,Z0,Z19,Z110,DA)

 .  Q

 Q

 ;

K6 ; KILL 'AM1X23' X-REF -- CALLED FROM FIELD 23.  LEVEL 3

 ; ACTUALLY WILL KILL 'AM1' X-REF.

 N Z0,Z1,Z19,Z110,Z124,Z125

 S Z0=$P($G(^PRC(443.75,DA,0)),U,11)  ;FIELD 5.5

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

 S Z124=$P(Z1,U,16)  ;FIELD 24

 S Z125=$P(Z1,U,17)  ;FIELD 25

 I Z0>0&(Z124>0)&(Z125=3) D

 .  K ^PRC(443.75,"AM",Z125,Z0,X,Z124,DA)

 .  ;

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

 .  ;

 .  S Z19=$P(Z1,U)  ;FIELD 9

 .  S Z110=$P(Z1,U,2)  ;FIELD 10

 .  S:Z0>0&(Z19]"")&(Z110>0) ^PRC(443.75,"AL1",2,Z0,Z19,Z110,DA)=""

 .  Q

 Q

 ;

S7 ; SET 'AMX25' X-REF -- CALLED FROM FIELD 25.  LEVEL 3

 ; ACTUALLY WILL SET 'AM' X-REF.

 N Z1,Z19,Z110,Z123,Z124

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

 S Z123=$P(Z1,U,15)  ;FIELD 23

 S Z124=$P(Z1,U,16)  ;FIELD 24

 I Z123]""&(Z124>0)&(X=3) D

 .  S ^PRC(443.75,"AM",X,Z123,Z124,DA)=""

 .  ;

 .  ; WENT UP A LEVEL -- NEED TO REMOVE FROM LOWER LEVEL.

 .  ;

 .  S Z19=$P(Z1,U)  ;FIELD 9

 .  S Z110=$P(Z1,U,2)  ;FIELD 10

 .  K:Z19]""&(Z110>0) ^PRC(443.75,"AL",2,Z19,Z110,DA)

 .  Q

 Q

 ;

K7 ; KILL 'AMX25' X-REF -- CALLED FROM FIELD 25.  LEVEL 3

 ; ACTUALLY WILL KILL 'AM' X-REF.

 N Z1,Z19,Z110,Z123,Z124

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

 S Z123=$P(Z1,U,15)  ;FIELD 23

 S Z124=$P(Z1,U,16)  ;FIELD 24

 I Z123]""&(Z124>0)&(X=3) D

 .  K ^PRC(443.75,"AM",X,Z123,Z124,DA)

 .  ;

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

 .  ;

 .  S Z19=$P(Z1,U)  ;FIELD 9

 .  S Z110=$P(Z1,U,2)  ;FIELD 10

 .  S:Z19]""&(Z110>0) ^PRC(443.75,"AL",2,Z19,Z110,DA)=""

 .  Q

 Q

 ;

S8 ; SET 'AM1X25' X-REF -- CALLED FROM FIELD 25.  LEVEL 3

 ; ACTUALLY WILL SET 'AM1' X-REF.

 N Z0,Z055,Z1,Z19,Z110,Z123,Z124

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

 S Z055=$P(Z0,U,11)  ;FIELD 5.5

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

 S Z123=$P(Z1,U,15)  ;FIELD 23

 S Z124=$P(Z1,U,16)  ;FIELD 24

 I Z055>0&(Z123]"")&(Z124>0)&(X=3) D

 .  S ^PRC(443.75,"AM1",X,Z055,Z123,Z124,DA)=""

 .  ;

 .  ; WENT UP A LEVEL -- NEED TO REMOVE SENDER FROM LOWER LEVEL.

 .  ;

 .  S Z19=$P(Z1,U)  ;FIELD 9

 .  S Z110=$P(Z1,U,2)  ;FIELD 10

 .  K:Z055>0&(Z19]"")&(Z110>0) ^PRC(443.75,"AL1",2,Z055,Z19,Z110,DA)

 .  Q

 Q

 ;

K8 ; KILL 'AM1X25' X-REF -- CALLED FROM FIELD 25.  LEVEL 3

 ; ACTUALLY WILL KILL 'AM1' X-REF.

 N Z0,Z055,Z1,Z19,Z110,Z123,Z124

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

 S Z055=$P(Z0,U,11)  ;FIELD 5.5

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

 S Z123=$P(Z1,U,15)  ;FIELD 23

 S Z124=$P(Z1,U,16)  ;FIELD 24

 I Z055>0&(Z123]"")&(Z124>0)&(X=3) D

 .  K ^PRC(443.75,"AM1",X,Z055,Z123,Z124,DA)

 .  ;

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

 .  ;

 .  S Z19=$P(Z1,U)  ;FIELD 9

 .  S Z110=$P(Z1,U,2)  ;FIELD 10

 .  S:Z055>0&(Z19]"")&(Z110>0) ^PRC(443.75,"AL1",2,Z055,Z19,Z110,DA)=""

 .  Q

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCOEDI2   8675     printed  Apr 23, 2025@18:26:22                                                                                                                                                                                                    Page 2

PRCOEDI2  ;WISC/DJM-IFCAP X-REF ROUTINE FOR FILE 443.75 CONTINUED ; [8/31/98 11:55am]

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

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

 +2       ;

S1        ; SET 'AL1' X-REF FOR ALL ACCEPTED OR REJECTED TRANSACTIONS BY

 +1       ; SENDER.

 +2       ; CALLED FROM FIELD 10.

 +3       ;

 +4       ; SEE IF FIELD 5.5 IS SET.  IF EMPTY DON'T SET THIS X-REF.

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

 +6       ;

 +7        SET SENDER=$PIECE($GET(^PRC(443.75,DA,0)),U,11)

 +8        IF SENDER=""

               KILL SENDER

               QUIT 

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

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

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

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

               Begin DoDot:1

 +13               SET ^PRC(443.75,"AL1",Z17,SENDER,Z1,+$EXTRACT(X,1,30),DA)=""

 +14      ;

 +15      ; NOW KILL 'AJ1' X-REF FOR THIS RECORD.

 +16      ;

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

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

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

 +20      ;

 +21      ; THE 1 AFTER "AJ1" IS THE LEVEL.

 +22      ;

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

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

 +24               QUIT 

               End DoDot:1

 +25       KILL Z0,Z1,Z4,Z7,Z17,SENDER

 +26       QUIT 

 +27      ;

K1        ; KILL 'AL1' X-REF FOR ALL ACCEPTED OR REJECTED TRANSACTIONS.

 +1       ; CALLED FROM FIELD 10.

 +2       ;

 +3        SET SENDER=$PIECE($GET(^PRC(443.75,DA,0)),U,11)

 +4        IF SENDER=""

               KILL SENDER

               QUIT 

 +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                KILL ^PRC(443.75,"AL1",Z17,SENDER,Z1,+$EXTRACT(X,1,30),DA)

 +10      ;

 +11      ; NOW LETS RESTORE 'AJ1' 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      ;THE 1 IN THE NEXT '^' PIECE AFTER "AJ1" IS THE LEVEL.

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

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

 +18               QUIT 

               End DoDot:1

 +19       KILL Z0,Z1,Z4,Z7,Z17,SENDER

 +20       QUIT 

 +21      ;

S2        ; SET 'AM1' X-REF FOR ALL POA TRANSACTIONS.

 +1       ; CALLED FROM FIELD 24.

 +2       ;

 +3        SET SENDER=$PIECE($GET(^PRC(443.75,DA,0)),U,11)

 +4        IF SENDER=""

               KILL SENDER

               QUIT 

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

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

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

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

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

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

               Begin DoDot:1

 +11               SET ^PRC(443.75,"AM1",Z17,SENDER,Z15,+$EXTRACT(X,1,30),DA)=""

 +12      ;

 +13      ; NOW KILL 'AL1' X-REF FOR THIS RECORD.

 +14      ; THE 2 AFTER "AL1" IS THE LEVEL.

 +15      ;

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

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

 +17               QUIT 

               End DoDot:1

 +18       KILL Z0,Z1,Z2,Z15,Z17,SENDER

 +19       QUIT 

 +20      ;

K2        ; KILL 'AM1' X-REF FOR ALL POA TRANSACTIONS.

 +1       ; CALLED FROM FIELD 24.

 +2       ;

 +3        SET SENDER=$PIECE($GET(^PRC(443.75,DA,0)),U,11)

 +4        IF SENDER=""

               KILL SENDER

               QUIT 

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

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

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

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

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

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

               Begin DoDot:1

 +11               KILL ^PRC(443.75,"AM1",Z17,SENDER,Z15,+$EXTRACT(X,1,30),DA)

 +12      ;

 +13      ; NOW SET 'AL1' X-REF FOR THIS RECORD.

 +14      ; THE 2 AFTER "AL1" IS THE LEVEL.

 +15      ;

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

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

 +17               QUIT 

               End DoDot:1

 +18       KILL Z0,Z1,Z2,Z15,Z17,SENDER

 +19       QUIT 

 +20      ;

S3        ; SET 'AJ1' X-REF FOR ALL ENTRIES WITHOUT ANY RESPONSE FROM AUSTIN.

 +1       ; CALLED FROM FIELD 6.

 +2       ;

 +3        SET SENDER=$PIECE($GET(^PRC(443.75,DA,0)),U,11)

 +4        IF SENDER=""

               KILL SENDER

               QUIT 

 +5        SET Z0=$PIECE($GET(^PRC(443.75,DA,0)),U,4)

 +6        SET Z1=$PIECE($GET(^PRC(443.75,DA,1)),U,17)

 +7        if Z1=1&(Z0]"")

               SET ^PRC(443.75,"AJ1",Z1,SENDER,Z0,$EXTRACT(X,1,30),DA)=""

 +8        KILL Z0,Z1

 +9        QUIT 

 +10      ;

K3        ; KILL 'AJ1' X-REF FOR ALL ENTRIES WITHOUT ANY RESPONSE FROM AUSTIN.

 +1       ; CALLED FROM FIELD 6.

 +2       ;

 +3        SET SENDER=$PIECE($GET(^PRC(443.75,DA,0)),U,11)

 +4        IF SENDER=""

               KILL SENDER

               QUIT 

 +5        SET Z0=$PIECE($GET(^PRC(443.75,DA,0)),U,4)

 +6        SET Z1=$PIECE($GET(^PRC(443.75,DA,1)),U,17)

 +7        if Z1=1&(Z0]"")

               KILL ^PRC(443.75,"AJ1",Z1,SENDER,Z0,$EXTRACT(X,1,30),DA)

 +8        KILL Z0,Z1

 +9        QUIT 

 +10      ;

S4        ; SET 'AL1X9' X-REF -- CALLED FROM FIELD 9.  LEVEL 2

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

 +2        NEW Z0,Z03,Z055,Z1,Z110,Z125

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

 +4       ;FIELD 5.5

           SET Z055=$PIECE(Z0,U,11)

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

 +6       ;FIELD 10

           SET Z110=$PIECE(Z1,U,2)

 +7       ;FIELD 25

           SET Z125=$PIECE(Z1,U,17)

 +8        IF Z055>0&(Z110>0)&(Z125=2)

               Begin DoDot:1

 +9                SET ^PRC(443.75,"AL1",Z125,Z055,X,Z110,DA)=""

 +10      ;

 +11      ; WENT UP A LEVEL -- NEED TO REMOVE SENDER FROM LOWER LEVEL.

 +12      ;

 +13      ;FIELD 3

                   SET Z03=$PIECE(Z0,U,4)

 +14      ;FIELD 6

                   SET Z0=$PIECE(Z0,U,7)

 +15               if Z03]""&(Z055>0)&(Z0>0)

                       KILL ^PRC(443.75,"AJ1",1,Z055,Z03,Z0,DA)

 +16               QUIT 

               End DoDot:1

 +17       QUIT 

 +18      ;

K4        ; KILL 'AL1X9' X-REF -- CALLED FROM FIELD 9.  LEVEL 2

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

 +2        NEW Z0,Z03,Z055,Z1,Z110,Z125

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

 +4       ;FIELD 5.5

           SET Z055=$PIECE(Z0,U,11)

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

 +6       ;FIELD 10

           SET Z110=$PIECE(Z1,U,2)

 +7       ;FIELD 25

           SET Z125=$PIECE(Z1,U,17)

 +8        IF Z055>0&(Z110>0)&(Z125=2)

               Begin DoDot:1

 +9                KILL ^PRC(443.75,"AL1",Z125,Z055,X,Z110,DA)

 +10      ;

 +11      ; NOW LETS RESTORE 'AJ1' X-REF FOR THIS RECORD.

 +12      ;

 +13      ;FIELD 3

                   SET Z03=$PIECE(Z0,U,4)

 +14      ;FIELD 6

                   SET Z0=$PIECE(Z0,U,7)

 +15               if Z03]""&(Z055>0)&(Z0>0)

                       SET ^PRC(443.75,"AJ1",1,Z055,Z03,Z0,DA)=""

               End DoDot:1

 +16       QUIT 

 +17      ;

S5        ; SET 'AMX23' X-REF -- CALLED FROM FIELD 23.  LEVEL 3

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

 +2        NEW Z1,Z19,Z110,Z124,Z125

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

 +4       ;FIELD 24

           SET Z124=$PIECE(Z1,U,16)

 +5       ;FIELD 25

           SET Z125=$PIECE(Z1,U,17)

 +6        IF Z124>0&(Z125=3)

               Begin DoDot:1

 +7                SET ^PRC(443.75,"AM",Z125,X,Z124,DA)=""

 +8       ;

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

 +10      ;THE 2 AFTER "AL" IS FIELD 25, LEVEL 2.

 +11      ;

 +12      ;FIELD 9

                   SET Z19=$PIECE(Z1,U)

 +13      ;FIELD 10

                   SET Z110=$PIECE(Z1,U,2)

 +14               if Z19]""&(Z110>0)

                       KILL ^PRC(443.75,"AL",2,Z19,Z110,DA)

 +15               QUIT 

               End DoDot:1

 +16       QUIT 

 +17      ;

K5        ; KILL 'AMX23' X-REF -- CALLED FROM FIELD 23.  LEVEL 3

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

 +2        NEW Z1,Z19,Z110,Z124,Z125

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

 +4       ;FIELD 24

           SET Z124=$PIECE(Z1,U,16)

 +5       ;FIELD 25

           SET Z125=$PIECE(Z1,U,17)

 +6        IF Z124>0&(Z125=3)

               Begin DoDot:1

 +7                KILL ^PRC(443.75,"AM",Z125,X,Z124,DA)

 +8       ;

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

 +10      ;

 +11      ;FIELD 9

                   SET Z19=$PIECE(Z1,U)

 +12      ;FIELD 10

                   SET Z110=$PIECE(Z1,U,2)

 +13               if Z19]""&(Z110>0)

                       SET ^PRC(443.75,"AL",2,Z19,Z110,DA)=""

 +14               QUIT 

               End DoDot:1

 +15       QUIT 

 +16      ;

S6        ; SET 'AM1X23' X-REF -- CALLED FROM FIELD 23.  LEVEL 3

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

 +2        NEW Z0,Z1,Z19,Z110,Z124,Z125

 +3       ;FIELD 5.5

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

 +4        SET Z1=$GET(^PRC(443.75,DA,1))

 +5       ;FIELD 24

           SET Z124=$PIECE(Z1,U,16)

 +6       ;FIELD 25

           SET Z125=$PIECE(Z1,U,17)

 +7        IF Z0>0&(Z124>0)&(Z125=3)

               Begin DoDot:1

 +8                SET ^PRC(443.75,"AM1",Z125,Z0,X,Z124,DA)=""

 +9       ;

 +10      ; WENT UP A LEVEL -- NEED TO REMOVE SENDER FROM LOWER LEVEL.

 +11      ;

 +12      ;FIELD 9

                   SET Z19=$PIECE(Z1,U)

 +13      ;FIELD 10

                   SET Z110=$PIECE(Z1,U,2)

 +14               if Z0>0&(Z19]"")&(Z110>0)

                       KILL ^PRC(443.75,"AL1",2,Z0,Z19,Z110,DA)

 +15               QUIT 

               End DoDot:1

 +16       QUIT 

 +17      ;

K6        ; KILL 'AM1X23' X-REF -- CALLED FROM FIELD 23.  LEVEL 3

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

 +2        NEW Z0,Z1,Z19,Z110,Z124,Z125

 +3       ;FIELD 5.5

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

 +4        SET Z1=$GET(^PRC(443.75,DA,1))

 +5       ;FIELD 24

           SET Z124=$PIECE(Z1,U,16)

 +6       ;FIELD 25

           SET Z125=$PIECE(Z1,U,17)

 +7        IF Z0>0&(Z124>0)&(Z125=3)

               Begin DoDot:1

 +8                KILL ^PRC(443.75,"AM",Z125,Z0,X,Z124,DA)

 +9       ;

 +10      ; NOW LETS RESTORE 'AL1' X-REF FOR THIS RECORD.

 +11      ;

 +12      ;FIELD 9

                   SET Z19=$PIECE(Z1,U)

 +13      ;FIELD 10

                   SET Z110=$PIECE(Z1,U,2)

 +14               if Z0>0&(Z19]"")&(Z110>0)

                       SET ^PRC(443.75,"AL1",2,Z0,Z19,Z110,DA)=""

 +15               QUIT 

               End DoDot:1

 +16       QUIT 

 +17      ;

S7        ; SET 'AMX25' X-REF -- CALLED FROM FIELD 25.  LEVEL 3

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

 +2        NEW Z1,Z19,Z110,Z123,Z124

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

 +4       ;FIELD 23

           SET Z123=$PIECE(Z1,U,15)

 +5       ;FIELD 24

           SET Z124=$PIECE(Z1,U,16)

 +6        IF Z123]""&(Z124>0)&(X=3)

               Begin DoDot:1

 +7                SET ^PRC(443.75,"AM",X,Z123,Z124,DA)=""

 +8       ;

 +9       ; WENT UP A LEVEL -- NEED TO REMOVE FROM LOWER LEVEL.

 +10      ;

 +11      ;FIELD 9

                   SET Z19=$PIECE(Z1,U)

 +12      ;FIELD 10

                   SET Z110=$PIECE(Z1,U,2)

 +13               if Z19]""&(Z110>0)

                       KILL ^PRC(443.75,"AL",2,Z19,Z110,DA)

 +14               QUIT 

               End DoDot:1

 +15       QUIT 

 +16      ;

K7        ; KILL 'AMX25' X-REF -- CALLED FROM FIELD 25.  LEVEL 3

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

 +2        NEW Z1,Z19,Z110,Z123,Z124

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

 +4       ;FIELD 23

           SET Z123=$PIECE(Z1,U,15)

 +5       ;FIELD 24

           SET Z124=$PIECE(Z1,U,16)

 +6        IF Z123]""&(Z124>0)&(X=3)

               Begin DoDot:1

 +7                KILL ^PRC(443.75,"AM",X,Z123,Z124,DA)

 +8       ;

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

 +10      ;

 +11      ;FIELD 9

                   SET Z19=$PIECE(Z1,U)

 +12      ;FIELD 10

                   SET Z110=$PIECE(Z1,U,2)

 +13               if Z19]""&(Z110>0)

                       SET ^PRC(443.75,"AL",2,Z19,Z110,DA)=""

 +14               QUIT 

               End DoDot:1

 +15       QUIT