VistA-WorldVistAEHR/r/IFCAP-PRC-PRX--PRCA--PRCN/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