PRCOEDI1 ;WISC/DJM-IFCAP X-REF ROUTINE FOR FILE 443.75 ; [8/27/98 11:11am]
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
S1 ; SET 'AJX3' X-REF -- CALLED FROM FIELD 3. LEVEL 1
; ACTUALLY WILL SET 'AJ' X-REF.
;
S Z0=$P($G(^PRC(443.75,DA,0)),U,7) ;FIELD 6
S Z1=$P($G(^PRC(443.75,DA,1)),U,17) ;FIELD 25
S:Z1=1&(Z0>0) ^PRC(443.75,"AJ",Z1,X,Z0,DA)=""
K Z0,Z1
Q
;
K1 ; KILL 'AJX3' X-REF -- CALLED FROM FIELD 3. LEVEL 1
; ACTUALLY WILL KILL 'AJ' X-REF.
;
S Z0=$P($G(^PRC(443.75,DA,0)),U,7) ;FIELD 6
S Z1=$P($G(^PRC(443.75,DA,1)),U,17) ;FIELD 25
K:Z1=1&(Z0>0) ^PRC(443.75,"AJ",Z1,X,Z0,DA)
K Z0,Z1
Q
;
S2 ; SET 'AJ1X3' X-REF -- CALLED FROM FIELD 3. LEVEL 1
; ACTUALLY WILL SET 'AJ1' X-REF.
;
S Z0=$G(^PRC(443.75,DA,0))
S Z055=$P(Z0,U,11) ;FIELD 5.5
S Z0=$P(Z0,U,7) ;FIELD 6
S Z1=$P($G(^PRC(443.75,DA,1)),U,17) ;FIELD 25
S:Z1=1&(Z0>0)&(Z055>0) ^PRC(443.75,"AJ1",Z1,Z055,X,Z0,DA)=""
K Z0,Z055,Z1
Q
;
K2 ; KILL 'AJ1X3' X-REF -- CALLED FROM FIELD 3. LEVEL 1
; ACTUALLY WILL KILL 'AJ1' X-REF.
;
S Z0=$G(^PRC(443.75,DA,0))
S Z055=$P(Z0,U,11) ;FIELD 5.5
S Z0=$P(Z0,U,7) ;FIELD 6
S Z1=$P($G(^PRC(443.75,DA,1)),U,17) ;FIELD 25
K:Z1=1&(Z0>0)&(Z055>0) ^PRC(443.75,"AJ1",Z1,Z055,X,Z0,DA)
K Z0,Z055,Z1
Q
;
S3 ; SET 'AJ1X55' X-REF -- CALLED FROM FIELD 5.5. LEVEL 1
; ACTUALLY WILL SET 'AJ1' X-REF.
;
S Z0=$G(^PRC(443.75,DA,0))
S Z03=$P(Z0,U,4) ;FIELD 3
S Z0=$P(Z0,U,7) ;FIELD 6
S Z1=$P($G(^PRC(443.75,DA,1)),U,17) ;FIELD 25
S:Z1=1&(Z03]"")&(Z0>0) ^PRC(443.75,"AJ1",Z1,X,Z03,Z0,DA)=""
K Z0,Z03,Z1
Q
;
K3 ; KILL 'AJ1X55' X-REF -- CALLED FROM FIELD 5.5. LEVEL 1
; ACTUALLY WILL KILL 'AJ1' X-REF.
;
S Z0=$G(^PRC(443.75,DA,0))
S Z03=$P(Z0,U,4) ;FIELD 3
S Z0=$P(Z0,U,7) ;FIELD 6
S Z1=$P($G(^PRC(443.75,DA,1)),U,17) ;FIELD 25
K:Z1=1&(Z03]"")&(Z0>0) ^PRC(443.75,"AJ1",Z1,X,Z03,Z0,DA)
K Z0,Z03,Z1
Q
;
S4 ; SET 'AL1X55' X-REF -- CALLED FROM FIELD 5.5. LEVEL 2
; ACTUALLY WILL SET 'AL1' X-REF.
;
N Z0,Z1,Z4,Z7,Z19,Z110
S Z1=$G(^PRC(443.75,DA,1))
S Z19=$P(Z1,U) ;FIELD 9
S Z110=$P(Z1,U,2) ;FIELD 10
S Z1=$P(Z1,U,17) ;FIELD 25
I Z1=2&(Z19]"")&(Z110>0) D
. S ^PRC(443.75,"AL1",Z1,X,Z19,Z110,DA)=""
. ;
. ; WENT UP A LEVEL -- NEED TO REMOVE SENDER FROM LOWER LEVEL.
. ;
. S Z0=$G(^PRC(443.75,DA,0))
. S Z4=$P(Z0,U,4) ;FIELD 3
. S Z7=$P(Z0,U,7) ;FIELD 6
. K:Z4]""&(Z7>0) ^PRC(443.75,"AJ1",1,X,Z4,Z7,DA)
. Q
Q
;
K4 ; KILL 'AL1X55' X-REF -- CALLED FROM FIELD 5.5. LEVEL 2
; ACTUALLY WILL KILL 'AL1' X-REF.
;
N Z1,Z19,Z110
S Z1=$G(^PRC(443.75,DA,1))
S Z19=$P(Z1,U) ;FIELD 9
S Z110=$P(Z1,U,2) ;FIELD 10
S Z1=$P(Z1,U,17) ;FIELD 25
I Z1=2&(Z19]"")&(Z110>0) D
. K ^PRC(443.75,"AL1",Z1,X,Z19,Z110,DA)
. ;
. ; CAN'T RESTORE TO LOWER LEVEL BECAUSE SENDER IS BEING REMOVED.
. Q
Q
;
S5 ; SET 'AM1X55' X-REF -- CALLED FROM FIELD 5.5. LEVEL 3
; ACTUALLY WILL SET 'AM1' X-REF.
;
N Z1,Z19,Z110,Z123,Z124
S Z1=$G(^PRC(443.75,DA,1))
S Z19=$P(Z1,U) ;FIELD 9
S Z123=$P(Z1,U,15) ;FIELD 23
S Z110=$P(Z1,U,2) ;FIELD 10
S Z124=$P(Z1,U,16) ;FIELD 24
S Z1=$P(Z1,U,17) ;FIELD 25
I Z1=3&(Z123]"")&(Z124>0) D
. S ^PRC(443.75,"AM1",Z1,X,Z123,Z124,DA)=""
. ;
. ; WENT UP A LEVEL -- NEED TO REMOVER SENDER FROM LOWER LEVEL.
. ;
. K:Z19]""&(Z110>0) ^PRC(443.75,"AL1",2,X,Z19,Z110,DA)
. Q
Q
;
K5 ; KILL 'AM1X55' X-REF -- CALLED FROM FIELD 5.5 LEVEL 3
; ACTUALLY WILL KILL 'AM1' X-REF.
;
N Z1,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
S Z1=$P(Z1,U,17) ;FIELD 25
I Z1=3&(Z123]"")&(Z124>0) D
. K ^PRC(443.75,"AM1",Z1,X,Z123,Z124,DA)
. ;
. ; CAN'T RESTORE TO LOWER LEVEL BECAUSE SENDER IS BEING REMOVED.
. ;
. Q
Q
;
S6 ; SET 'AJX25' X-REF -- CALLED FROM FIELD 25. LEVEL 1
; ACTUALLY WILL SET 'AJ' X-REF.
;
N Z0,Z03
S Z0=$G(^PRC(443.75,DA,0))
S Z03=$P(Z0,U,4) ;FIELD 3
S Z0=$P(Z0,U,7) ;FIELD 6
S:X=1&(Z0>0)&(Z03]"") ^PRC(443.75,"AJ",X,Z03,Z0,DA)=""
Q
;
K6 ; KILL 'AJX25' X-REF -- CALLED FROM FIELD 25. LEVEL 1
; ACTUALLY WILL KILL 'AJ' X-REF.
;
N Z0,Z03
S Z0=$G(^PRC(443.75,DA,0))
S Z03=$P(Z0,U,4) ;FIELD 3
S Z0=$P(Z0,U,7) ;FIELD 6
K:Z0>0&(Z03]"") ^PRC(443.75,"AJ",X,Z03,Z0,DA)
Q
;
S7 ; SET 'AJ1X25' X-REF -- CALLED FROM FIELD 25. LEVEL 1
; ACTUALLY WILL SET 'AJ1' X-REF.
;
N Z0,Z03,Z055
S Z0=$G(^PRC(443.75,DA,0))
S Z03=$P(Z0,U,4) ;FIELD 3
S Z055=$P(Z0,U,11) ;FIELD 5.5
S Z0=$P(Z0,U,7) ;FIELD 6
S:X=1&(Z03]"")&(Z055>0)&(Z0>0) ^PRC(443.75,"AJ1",X,Z055,Z03,Z0,DA)=""
Q
;
K7 ; KILL 'AJ1X25' X-REF -- CALLED FROM FIELD 25. LEVEL 1
; ACTUALLY WILL KILL 'AJ1' X-REF.
;
N Z0,Z03,Z055
S Z0=$G(^PRC(443.75,DA,0))
S Z03=$P(Z0,U,4) ;FIELD 3
S Z055=$P(Z0,U,11) ;FIELD 5.5
S Z0=$P(Z0,U,7) ;FIELD 6
K:Z03]""&(Z055>0)&(Z0>0) ^PRC(443.75,"AJ1",X,Z055,Z03,Z0,DA)
Q
;
S8 ; SET 'ALX25' X-REF -- CALLED FROM FIELD 25. LEVEL 2
; ACTUALLY WILL SET 'AL' X-REF.
;
N Z0,Z03,Z1,Z19
S Z1=$G(^PRC(443.75,DA,1))
S Z19=$P(Z1,U) ;FIELD 9
S Z1=$P(Z1,U,2) ;FIELD 10
I X=2&(Z1>0)&(Z19]"") D
. S ^PRC(443.75,"AL",X,Z19,Z1,DA)=""
. ;
. ; WENT UP A LEVEL -- NEED TO REMOVE LOWER LEVEL.
. ;
. S Z0=$G(^PRC(443.75,DA,0))
. S Z03=$P(Z0,U,4) ;FIELD 3
. S Z0=$P(Z0,U,7) ;FIELD 6
. K:Z03]""&(Z0>0) ^PRC(443.75,"AJ",1,Z03,Z0,DA)
. Q
Q
;
K8 ; KILL 'ALX25' X-REF -- CALLED FROM FIELD 25. LEVEL 2
; ACTUALLY WILL KILL 'AL' X-REF.
;
N Z0,Z03,Z1,Z19
S Z1=$G(^PRC(443.75,DA,1))
S Z19=$P(Z1,U) ;FIELD 9
S Z1=$P(Z1,U,2) ;FIELD 10
I Z1>0&(Z19]"") D
. K ^PRC(443.75,"AL",X,Z19,Z1,DA)
. ;
. ; NOW LETS RESTORE 'AJ' X-REF FOR THIS RECORD.
. ;
. S Z0=$G(^PRC(443.75,DA,0))
. S Z03=$P(Z0,U,4) ;FIELD 3
. S Z0=$P(Z0,U,7) ;FIELD 6
. S:Z03]""&(Z0>0) ^PRC(443.75,"AJ",1,Z03,Z0,DA)=""
. Q
Q
;
S9 ; SET 'AL1X25' X-REF -- CALLED FROM FIELD 25. LEVEL 2
; ACTUALLY WILL SET 'AL1' X-REF.
;
N Z0,Z03,Z055,Z1,Z19
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 Z19=$P(Z1,U) ;FIELD 9
S Z1=$P(Z1,U,2) ;FIELD 10
I X=2&(Z055>0)&(Z19]"")&(Z1>0) D
. S ^PRC(443.75,"AL1",X,Z055,Z19,Z1,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
;
K9 ; KILL 'AL1X25' X-REF -- CALLED FROM FIELD 25. LEVEL 2
; ACTUALLY WILL KILL 'AL1' X-REF.
;
N Z0,Z03,Z055,Z1,Z19
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 Z19=$P(Z1,U) ;FIELD 9
S Z1=$P(Z1,U,2) ;FIELD 10
I Z055>0&(Z19]"")&(Z1>0) D
. K ^PRC(443.75,"AL1",X,Z055,Z19,Z1,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
Q
;
S10 ; SET 'ALX9' X-REF -- CALLED FROM FIELD 9. LEVEL 2
; ACTUALLY WILL SET 'AL' X-REF.
;
N Z0,Z03,Z1,Z110,Z125
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 Z110>0&(Z125=2) D
. S ^PRC(443.75,"AL",Z125,X,Z110,DA)=""
. ;
. ; WENT UP A LEVEL -- NEED TO REMOVE LOWER LEVEL.
. ;
. S Z0=$G(^PRC(443.75,DA,0))
. S Z03=$P(Z0,U,4) ;FIELD 3
. S Z0=$P(Z0,U,7) ;FIELD 6
. K:Z03]""&(Z0>0) ^PRC(443.75,"AJ",1,Z03,Z0,DA)
. Q
Q
;
K10 ; KILL 'ALX9' X-REF -- CALLED FROM FIELD 9. LEVEL 2
; ACTUALLY WILL KILL 'AL' X-REF.
;
N Z0,Z03,Z1,Z110,Z125
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 Z110>0&(Z125=2) D
. K ^PRC(443.75,"AL",Z125,X,Z110,DA)
. ;
. ; NOW LETS RESTORE 'AJ' X-REF FOR THIS RECORD.
. ;
. S Z0=$G(^PRC(443.75,DA,0))
. S Z03=$P(Z0,U,4) ;FIELD 3
. S Z0=$P(Z0,U,7) ;FIELD 6
. S:Z03]""&(Z0>0) ^PRC(443.75,"AJ",1,Z03,Z0,DA)=""
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCOEDI1 8111 printed Apr 09, 2024@21:01:55 Page 2
PRCOEDI1 ;WISC/DJM-IFCAP X-REF ROUTINE FOR FILE 443.75 ; [8/27/98 11:11am]
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
S1 ; SET 'AJX3' X-REF -- CALLED FROM FIELD 3. LEVEL 1
+1 ; ACTUALLY WILL SET 'AJ' X-REF.
+2 ;
+3 ;FIELD 6
SET Z0=$PIECE($GET(^PRC(443.75,DA,0)),U,7)
+4 ;FIELD 25
SET Z1=$PIECE($GET(^PRC(443.75,DA,1)),U,17)
+5 if Z1=1&(Z0>0)
SET ^PRC(443.75,"AJ",Z1,X,Z0,DA)=""
+6 KILL Z0,Z1
+7 QUIT
+8 ;
K1 ; KILL 'AJX3' X-REF -- CALLED FROM FIELD 3. LEVEL 1
+1 ; ACTUALLY WILL KILL 'AJ' X-REF.
+2 ;
+3 ;FIELD 6
SET Z0=$PIECE($GET(^PRC(443.75,DA,0)),U,7)
+4 ;FIELD 25
SET Z1=$PIECE($GET(^PRC(443.75,DA,1)),U,17)
+5 if Z1=1&(Z0>0)
KILL ^PRC(443.75,"AJ",Z1,X,Z0,DA)
+6 KILL Z0,Z1
+7 QUIT
+8 ;
S2 ; SET 'AJ1X3' X-REF -- CALLED FROM FIELD 3. LEVEL 1
+1 ; ACTUALLY WILL SET 'AJ1' X-REF.
+2 ;
+3 SET Z0=$GET(^PRC(443.75,DA,0))
+4 ;FIELD 5.5
SET Z055=$PIECE(Z0,U,11)
+5 ;FIELD 6
SET Z0=$PIECE(Z0,U,7)
+6 ;FIELD 25
SET Z1=$PIECE($GET(^PRC(443.75,DA,1)),U,17)
+7 if Z1=1&(Z0>0)&(Z055>0)
SET ^PRC(443.75,"AJ1",Z1,Z055,X,Z0,DA)=""
+8 KILL Z0,Z055,Z1
+9 QUIT
+10 ;
K2 ; KILL 'AJ1X3' X-REF -- CALLED FROM FIELD 3. LEVEL 1
+1 ; ACTUALLY WILL KILL 'AJ1' X-REF.
+2 ;
+3 SET Z0=$GET(^PRC(443.75,DA,0))
+4 ;FIELD 5.5
SET Z055=$PIECE(Z0,U,11)
+5 ;FIELD 6
SET Z0=$PIECE(Z0,U,7)
+6 ;FIELD 25
SET Z1=$PIECE($GET(^PRC(443.75,DA,1)),U,17)
+7 if Z1=1&(Z0>0)&(Z055>0)
KILL ^PRC(443.75,"AJ1",Z1,Z055,X,Z0,DA)
+8 KILL Z0,Z055,Z1
+9 QUIT
+10 ;
S3 ; SET 'AJ1X55' X-REF -- CALLED FROM FIELD 5.5. LEVEL 1
+1 ; ACTUALLY WILL SET 'AJ1' X-REF.
+2 ;
+3 SET Z0=$GET(^PRC(443.75,DA,0))
+4 ;FIELD 3
SET Z03=$PIECE(Z0,U,4)
+5 ;FIELD 6
SET Z0=$PIECE(Z0,U,7)
+6 ;FIELD 25
SET Z1=$PIECE($GET(^PRC(443.75,DA,1)),U,17)
+7 if Z1=1&(Z03]"")&(Z0>0)
SET ^PRC(443.75,"AJ1",Z1,X,Z03,Z0,DA)=""
+8 KILL Z0,Z03,Z1
+9 QUIT
+10 ;
K3 ; KILL 'AJ1X55' X-REF -- CALLED FROM FIELD 5.5. LEVEL 1
+1 ; ACTUALLY WILL KILL 'AJ1' X-REF.
+2 ;
+3 SET Z0=$GET(^PRC(443.75,DA,0))
+4 ;FIELD 3
SET Z03=$PIECE(Z0,U,4)
+5 ;FIELD 6
SET Z0=$PIECE(Z0,U,7)
+6 ;FIELD 25
SET Z1=$PIECE($GET(^PRC(443.75,DA,1)),U,17)
+7 if Z1=1&(Z03]"")&(Z0>0)
KILL ^PRC(443.75,"AJ1",Z1,X,Z03,Z0,DA)
+8 KILL Z0,Z03,Z1
+9 QUIT
+10 ;
S4 ; SET 'AL1X55' X-REF -- CALLED FROM FIELD 5.5. LEVEL 2
+1 ; ACTUALLY WILL SET 'AL1' X-REF.
+2 ;
+3 NEW Z0,Z1,Z4,Z7,Z19,Z110
+4 SET Z1=$GET(^PRC(443.75,DA,1))
+5 ;FIELD 9
SET Z19=$PIECE(Z1,U)
+6 ;FIELD 10
SET Z110=$PIECE(Z1,U,2)
+7 ;FIELD 25
SET Z1=$PIECE(Z1,U,17)
+8 IF Z1=2&(Z19]"")&(Z110>0)
Begin DoDot:1
+9 SET ^PRC(443.75,"AL1",Z1,X,Z19,Z110,DA)=""
+10 ;
+11 ; WENT UP A LEVEL -- NEED TO REMOVE SENDER FROM LOWER LEVEL.
+12 ;
+13 SET Z0=$GET(^PRC(443.75,DA,0))
+14 ;FIELD 3
SET Z4=$PIECE(Z0,U,4)
+15 ;FIELD 6
SET Z7=$PIECE(Z0,U,7)
+16 if Z4]""&(Z7>0)
KILL ^PRC(443.75,"AJ1",1,X,Z4,Z7,DA)
+17 QUIT
End DoDot:1
+18 QUIT
+19 ;
K4 ; KILL 'AL1X55' X-REF -- CALLED FROM FIELD 5.5. LEVEL 2
+1 ; ACTUALLY WILL KILL 'AL1' X-REF.
+2 ;
+3 NEW Z1,Z19,Z110
+4 SET Z1=$GET(^PRC(443.75,DA,1))
+5 ;FIELD 9
SET Z19=$PIECE(Z1,U)
+6 ;FIELD 10
SET Z110=$PIECE(Z1,U,2)
+7 ;FIELD 25
SET Z1=$PIECE(Z1,U,17)
+8 IF Z1=2&(Z19]"")&(Z110>0)
Begin DoDot:1
+9 KILL ^PRC(443.75,"AL1",Z1,X,Z19,Z110,DA)
+10 ;
+11 ; CAN'T RESTORE TO LOWER LEVEL BECAUSE SENDER IS BEING REMOVED.
+12 QUIT
End DoDot:1
+13 QUIT
+14 ;
S5 ; SET 'AM1X55' X-REF -- CALLED FROM FIELD 5.5. LEVEL 3
+1 ; ACTUALLY WILL SET 'AM1' X-REF.
+2 ;
+3 NEW Z1,Z19,Z110,Z123,Z124
+4 SET Z1=$GET(^PRC(443.75,DA,1))
+5 ;FIELD 9
SET Z19=$PIECE(Z1,U)
+6 ;FIELD 23
SET Z123=$PIECE(Z1,U,15)
+7 ;FIELD 10
SET Z110=$PIECE(Z1,U,2)
+8 ;FIELD 24
SET Z124=$PIECE(Z1,U,16)
+9 ;FIELD 25
SET Z1=$PIECE(Z1,U,17)
+10 IF Z1=3&(Z123]"")&(Z124>0)
Begin DoDot:1
+11 SET ^PRC(443.75,"AM1",Z1,X,Z123,Z124,DA)=""
+12 ;
+13 ; WENT UP A LEVEL -- NEED TO REMOVER SENDER FROM LOWER LEVEL.
+14 ;
+15 if Z19]""&(Z110>0)
KILL ^PRC(443.75,"AL1",2,X,Z19,Z110,DA)
+16 QUIT
End DoDot:1
+17 QUIT
+18 ;
K5 ; KILL 'AM1X55' X-REF -- CALLED FROM FIELD 5.5 LEVEL 3
+1 ; ACTUALLY WILL KILL 'AM1' X-REF.
+2 ;
+3 NEW Z1,Z123,Z124
+4 SET Z1=$GET(^PRC(443.75,DA,1))
+5 ;FIELD 23
SET Z123=$PIECE(Z1,U,15)
+6 ;FIELD 24
SET Z124=$PIECE(Z1,U,16)
+7 ;FIELD 25
SET Z1=$PIECE(Z1,U,17)
+8 IF Z1=3&(Z123]"")&(Z124>0)
Begin DoDot:1
+9 KILL ^PRC(443.75,"AM1",Z1,X,Z123,Z124,DA)
+10 ;
+11 ; CAN'T RESTORE TO LOWER LEVEL BECAUSE SENDER IS BEING REMOVED.
+12 ;
+13 QUIT
End DoDot:1
+14 QUIT
+15 ;
S6 ; SET 'AJX25' X-REF -- CALLED FROM FIELD 25. LEVEL 1
+1 ; ACTUALLY WILL SET 'AJ' X-REF.
+2 ;
+3 NEW Z0,Z03
+4 SET Z0=$GET(^PRC(443.75,DA,0))
+5 ;FIELD 3
SET Z03=$PIECE(Z0,U,4)
+6 ;FIELD 6
SET Z0=$PIECE(Z0,U,7)
+7 if X=1&(Z0>0)&(Z03]"")
SET ^PRC(443.75,"AJ",X,Z03,Z0,DA)=""
+8 QUIT
+9 ;
K6 ; KILL 'AJX25' X-REF -- CALLED FROM FIELD 25. LEVEL 1
+1 ; ACTUALLY WILL KILL 'AJ' X-REF.
+2 ;
+3 NEW Z0,Z03
+4 SET Z0=$GET(^PRC(443.75,DA,0))
+5 ;FIELD 3
SET Z03=$PIECE(Z0,U,4)
+6 ;FIELD 6
SET Z0=$PIECE(Z0,U,7)
+7 if Z0>0&(Z03]"")
KILL ^PRC(443.75,"AJ",X,Z03,Z0,DA)
+8 QUIT
+9 ;
S7 ; SET 'AJ1X25' X-REF -- CALLED FROM FIELD 25. LEVEL 1
+1 ; ACTUALLY WILL SET 'AJ1' X-REF.
+2 ;
+3 NEW Z0,Z03,Z055
+4 SET Z0=$GET(^PRC(443.75,DA,0))
+5 ;FIELD 3
SET Z03=$PIECE(Z0,U,4)
+6 ;FIELD 5.5
SET Z055=$PIECE(Z0,U,11)
+7 ;FIELD 6
SET Z0=$PIECE(Z0,U,7)
+8 if X=1&(Z03]"")&(Z055>0)&(Z0>0)
SET ^PRC(443.75,"AJ1",X,Z055,Z03,Z0,DA)=""
+9 QUIT
+10 ;
K7 ; KILL 'AJ1X25' X-REF -- CALLED FROM FIELD 25. LEVEL 1
+1 ; ACTUALLY WILL KILL 'AJ1' X-REF.
+2 ;
+3 NEW Z0,Z03,Z055
+4 SET Z0=$GET(^PRC(443.75,DA,0))
+5 ;FIELD 3
SET Z03=$PIECE(Z0,U,4)
+6 ;FIELD 5.5
SET Z055=$PIECE(Z0,U,11)
+7 ;FIELD 6
SET Z0=$PIECE(Z0,U,7)
+8 if Z03]""&(Z055>0)&(Z0>0)
KILL ^PRC(443.75,"AJ1",X,Z055,Z03,Z0,DA)
+9 QUIT
+10 ;
S8 ; SET 'ALX25' X-REF -- CALLED FROM FIELD 25. LEVEL 2
+1 ; ACTUALLY WILL SET 'AL' X-REF.
+2 ;
+3 NEW Z0,Z03,Z1,Z19
+4 SET Z1=$GET(^PRC(443.75,DA,1))
+5 ;FIELD 9
SET Z19=$PIECE(Z1,U)
+6 ;FIELD 10
SET Z1=$PIECE(Z1,U,2)
+7 IF X=2&(Z1>0)&(Z19]"")
Begin DoDot:1
+8 SET ^PRC(443.75,"AL",X,Z19,Z1,DA)=""
+9 ;
+10 ; WENT UP A LEVEL -- NEED TO REMOVE LOWER LEVEL.
+11 ;
+12 SET Z0=$GET(^PRC(443.75,DA,0))
+13 ;FIELD 3
SET Z03=$PIECE(Z0,U,4)
+14 ;FIELD 6
SET Z0=$PIECE(Z0,U,7)
+15 if Z03]""&(Z0>0)
KILL ^PRC(443.75,"AJ",1,Z03,Z0,DA)
+16 QUIT
End DoDot:1
+17 QUIT
+18 ;
K8 ; KILL 'ALX25' X-REF -- CALLED FROM FIELD 25. LEVEL 2
+1 ; ACTUALLY WILL KILL 'AL' X-REF.
+2 ;
+3 NEW Z0,Z03,Z1,Z19
+4 SET Z1=$GET(^PRC(443.75,DA,1))
+5 ;FIELD 9
SET Z19=$PIECE(Z1,U)
+6 ;FIELD 10
SET Z1=$PIECE(Z1,U,2)
+7 IF Z1>0&(Z19]"")
Begin DoDot:1
+8 KILL ^PRC(443.75,"AL",X,Z19,Z1,DA)
+9 ;
+10 ; NOW LETS RESTORE 'AJ' X-REF FOR THIS RECORD.
+11 ;
+12 SET Z0=$GET(^PRC(443.75,DA,0))
+13 ;FIELD 3
SET Z03=$PIECE(Z0,U,4)
+14 ;FIELD 6
SET Z0=$PIECE(Z0,U,7)
+15 if Z03]""&(Z0>0)
SET ^PRC(443.75,"AJ",1,Z03,Z0,DA)=""
+16 QUIT
End DoDot:1
+17 QUIT
+18 ;
S9 ; SET 'AL1X25' X-REF -- CALLED FROM FIELD 25. LEVEL 2
+1 ; ACTUALLY WILL SET 'AL1' X-REF.
+2 ;
+3 NEW Z0,Z03,Z055,Z1,Z19
+4 SET Z0=$GET(^PRC(443.75,DA,0))
+5 ;FIELD 5.5
SET Z055=$PIECE(Z0,U,11)
+6 SET Z1=$GET(^PRC(443.75,DA,1))
+7 ;FIELD 9
SET Z19=$PIECE(Z1,U)
+8 ;FIELD 10
SET Z1=$PIECE(Z1,U,2)
+9 IF X=2&(Z055>0)&(Z19]"")&(Z1>0)
Begin DoDot:1
+10 SET ^PRC(443.75,"AL1",X,Z055,Z19,Z1,DA)=""
+11 ;
+12 ; WENT UP A LEVEL -- NEED TO REMOVE SENDER FROM LOWER LEVEL
+13 ;
+14 ;FIELD 3
SET Z03=$PIECE(Z0,U,4)
+15 ;FIELD 6
SET Z0=$PIECE(Z0,U,7)
+16 if Z03]""&(Z055>0)&(Z0>0)
KILL ^PRC(443.75,"AJ1",1,Z055,Z03,Z0,DA)
+17 QUIT
End DoDot:1
+18 QUIT
+19 ;
K9 ; KILL 'AL1X25' X-REF -- CALLED FROM FIELD 25. LEVEL 2
+1 ; ACTUALLY WILL KILL 'AL1' X-REF.
+2 ;
+3 NEW Z0,Z03,Z055,Z1,Z19
+4 SET Z0=$GET(^PRC(443.75,DA,0))
+5 ;FIELD 5.5
SET Z055=$PIECE(Z0,U,11)
+6 SET Z1=$GET(^PRC(443.75,DA,1))
+7 ;FIELD 9
SET Z19=$PIECE(Z1,U)
+8 ;FIELD 10
SET Z1=$PIECE(Z1,U,2)
+9 IF Z055>0&(Z19]"")&(Z1>0)
Begin DoDot:1
+10 KILL ^PRC(443.75,"AL1",X,Z055,Z19,Z1,DA)
+11 ;
+12 ; NOW LETS RESTORE 'AJ1' X-REF FOR THIS RECORD.
+13 ;
+14 ;FIELD 3
SET Z03=$PIECE(Z0,U,4)
+15 ;FIELD 6
SET Z0=$PIECE(Z0,U,7)
+16 if Z03]""&(Z055>0)&(Z0>0)
SET ^PRC(443.75,"AJ1",1,Z055,Z03,Z0,DA)=""
+17 QUIT
End DoDot:1
+18 QUIT
+19 ;
S10 ; SET 'ALX9' X-REF -- CALLED FROM FIELD 9. LEVEL 2
+1 ; ACTUALLY WILL SET 'AL' X-REF.
+2 ;
+3 NEW Z0,Z03,Z1,Z110,Z125
+4 SET Z1=$GET(^PRC(443.75,DA,1))
+5 ;FIELD 10
SET Z110=$PIECE(Z1,U,2)
+6 ;FIELD 25
SET Z125=$PIECE(Z1,U,17)
+7 IF Z110>0&(Z125=2)
Begin DoDot:1
+8 SET ^PRC(443.75,"AL",Z125,X,Z110,DA)=""
+9 ;
+10 ; WENT UP A LEVEL -- NEED TO REMOVE LOWER LEVEL.
+11 ;
+12 SET Z0=$GET(^PRC(443.75,DA,0))
+13 ;FIELD 3
SET Z03=$PIECE(Z0,U,4)
+14 ;FIELD 6
SET Z0=$PIECE(Z0,U,7)
+15 if Z03]""&(Z0>0)
KILL ^PRC(443.75,"AJ",1,Z03,Z0,DA)
+16 QUIT
End DoDot:1
+17 QUIT
+18 ;
K10 ; KILL 'ALX9' X-REF -- CALLED FROM FIELD 9. LEVEL 2
+1 ; ACTUALLY WILL KILL 'AL' X-REF.
+2 ;
+3 NEW Z0,Z03,Z1,Z110,Z125
+4 SET Z1=$GET(^PRC(443.75,DA,1))
+5 ;FIELD 10
SET Z110=$PIECE(Z1,U,2)
+6 ;FIELD 25
SET Z125=$PIECE(Z1,U,17)
+7 IF Z110>0&(Z125=2)
Begin DoDot:1
+8 KILL ^PRC(443.75,"AL",Z125,X,Z110,DA)
+9 ;
+10 ; NOW LETS RESTORE 'AJ' X-REF FOR THIS RECORD.
+11 ;
+12 SET Z0=$GET(^PRC(443.75,DA,0))
+13 ;FIELD 3
SET Z03=$PIECE(Z0,U,4)
+14 ;FIELD 6
SET Z0=$PIECE(Z0,U,7)
+15 if Z03]""&(Z0>0)
SET ^PRC(443.75,"AJ",1,Z03,Z0,DA)=""
+16 QUIT
End DoDot:1
+17 QUIT
