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 ---[H[J[2J[HPRCOEDI2 8675 printed Dec 13, 2024@02:11:52 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
+16 ;
S8 ; SET 'AM1X25' X-REF -- CALLED FROM FIELD 25. LEVEL 3
+1 ; ACTUALLY WILL SET 'AM1' X-REF.
+2 NEW Z0,Z055,Z1,Z19,Z110,Z123,Z124
+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 23
SET Z123=$PIECE(Z1,U,15)
+7 ;FIELD 24
SET Z124=$PIECE(Z1,U,16)
+8 IF Z055>0&(Z123]"")&(Z124>0)&(X=3)
Begin DoDot:1
+9 SET ^PRC(443.75,"AM1",X,Z055,Z123,Z124,DA)=""
+10 ;
+11 ; WENT UP A LEVEL -- NEED TO REMOVE SENDER FROM LOWER LEVEL.
+12 ;
+13 ;FIELD 9
SET Z19=$PIECE(Z1,U)
+14 ;FIELD 10
SET Z110=$PIECE(Z1,U,2)
+15 if Z055>0&(Z19]"")&(Z110>0)
KILL ^PRC(443.75,"AL1",2,Z055,Z19,Z110,DA)
+16 QUIT
End DoDot:1
+17 QUIT
+18 ;
K8 ; KILL 'AM1X25' X-REF -- CALLED FROM FIELD 25. LEVEL 3
+1 ; ACTUALLY WILL KILL 'AM1' X-REF.
+2 NEW Z0,Z055,Z1,Z19,Z110,Z123,Z124
+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 23
SET Z123=$PIECE(Z1,U,15)
+7 ;FIELD 24
SET Z124=$PIECE(Z1,U,16)
+8 IF Z055>0&(Z123]"")&(Z124>0)&(X=3)
Begin DoDot:1
+9 KILL ^PRC(443.75,"AM1",X,Z055,Z123,Z124,DA)
+10 ;
+11 ; NOW LETS RESTORE 'AL1' X-REF FOR THIS RECORD.
+12 ;
+13 ;FIELD 9
SET Z19=$PIECE(Z1,U)
+14 ;FIELD 10
SET Z110=$PIECE(Z1,U,2)
+15 if Z055>0&(Z19]"")&(Z110>0)
SET ^PRC(443.75,"AL1",2,Z055,Z19,Z110,DA)=""
+16 QUIT
End DoDot:1
+17 QUIT
