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