236 lines
6.7 KiB
Mathematica
236 lines
6.7 KiB
Mathematica
PRCOEDIS ;WISC/DJM-IFCAP X-REF ROUTINE FOR FILE 443.75 ; [8/31/98 1:24pm]
|
|
V ;;5.1;IFCAP;;Oct 20, 2000
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
;
|
|
S1 ; SET 'AC' X-REF -- CALLED FROM FIELD 1. RFQ
|
|
N N0
|
|
S N0=$G(^PRC(443.75,DA,0))
|
|
I $P(N0,U,4)="RFQ",$P(N0,U,6)]"",$P(N0,U,10)]"" S ^PRC(443.75,"AC",$P(N0,U,4),X,$P(N0,U,6),$P(N0,U,10),DA)=""
|
|
Q
|
|
;
|
|
K1 ; KILL 'AC' X-REF -- CALLED FROM FIELD 1. RFQ
|
|
N N0
|
|
S N0=$G(^PRC(443.75,DA,0))
|
|
I $P(N0,U,4)="RFQ",$P(N0,U,6)]"",$P(N0,U,10)]"" K ^PRC(443.75,"AC",$P(N0,U,4),X,$P(N0,U,6),$P(N0,U,10),DA)
|
|
Q
|
|
;
|
|
S2 ; SET 'AD' X-REF -- CALLED FROM FIELD 3. RFQ
|
|
; ACTUALLY WILL SET 'AC' X-REF.
|
|
N N0
|
|
S N0=$G(^PRC(443.75,DA,0))
|
|
I $P(N0,U,2)]"",$P(N0,U,6)]"",$P(N0,U,10)]"",X="RFQ" S ^PRC(443.75,"AC",X,$P(N0,U,2),$P(N0,U,6),$P(N0,U,10),DA)=""
|
|
Q
|
|
;
|
|
K2 ; KILL 'AD' X-REF -- CALLED FROM FIELD 3. RFQ
|
|
; ACTUALLY WILL KILL 'AC' X-REF.
|
|
N N0
|
|
S N0=$G(^PRC(443.75,DA,0))
|
|
I $P(N0,U,2)]"",$P(N0,U,6)]"",$P(N0,U,10)]"",X="RFQ" K ^PRC(443.75,"AC",X,$P(N0,U,2),$P(N0,U,6),$P(N0,U,10),DA)
|
|
Q
|
|
;
|
|
S3 ; SET 'AE' X-REF -- CALLED FROM FIELD 5. RFQ
|
|
; ACTUALLY WILL SET 'AC' X-REF.
|
|
N N0
|
|
S N0=$G(^PRC(443.75,DA,0))
|
|
I $P(N0,U,2)]"",$P(N0,U,4)="RFQ",$P(N0,U,10)]"" S ^PRC(443.75,"AC",$P(N0,U,4),$P(N0,U,2),X,$P(N0,U,10),DA)=""
|
|
Q
|
|
;
|
|
K3 ; KILL 'AE' X-REF -- CALLED FROM FIELD 5. RFQ
|
|
; ACTUALLY WILL KILL 'AC' X-REF.
|
|
N N0
|
|
S N0=$G(^PRC(443.75,DA,0))
|
|
I $P(N0,U,2)]"",$P(N0,U,4)="RFQ",$P(N0,U,10)]"" K ^PRC(443.75,"AC",$P(N0,U,4),$P(N0,U,2),X,$P(N0,U,10),DA)
|
|
Q
|
|
;
|
|
S4 ; SET 'AF' X-REF -- CALLED FROM FIELD 1. TXT
|
|
N N0
|
|
S N0=$G(^PRC(443.75,DA,0))
|
|
I $P(N0,U,3)]"",$P(N0,U,4)="TXT",$P(N0,U,6)]"" S ^PRC(443.75,"AF",$P(N0,U,4),X,$P(N0,U,6),$P(N0,U,3),DA)=""
|
|
Q
|
|
;
|
|
K4 ; KILL 'AF' X-REF -- CALLED FROM FIELD 1. TXT
|
|
N N0
|
|
S N0=$G(^PRC(443.75,DA,0))
|
|
I $P(N0,U,3)]"",$P(N0,U,4)="TXT",$P(N0,U,6)]"" K ^PRC(443.75,"AF",$P(N0,U,4),X,$P(N0,U,6),$P(N0,U,3),DA)
|
|
Q
|
|
;
|
|
S5 ; SET 'AG' X-REF -- CALLED FROM FIELD 2. TXT
|
|
; ACTUALLY WILL SET 'AF' X-REF.
|
|
N N0
|
|
S N0=$G(^PRC(443.75,DA,0))
|
|
I $P(N0,U,2)]"",$P(N0,U,4)="TXT",$P(N0,U,6)]"" S ^PRC(443.75,"AF",$P(N0,U,4),$P(N0,U,2),$P(N0,U,6),X,DA)=""
|
|
Q
|
|
;
|
|
K5 ; KILL 'AG' X-REF -- CALLED FROM FIELD 2. TXT
|
|
; ACTUALLY WILL KILL 'AF' X-REF.
|
|
N N0
|
|
S N0=$G(^PRC(443.75,DA,0))
|
|
I $P(N0,U,2)]"",$P(N0,U,4)="TXT",$P(N0,U,6)]"" K ^PRC(443.75,"AF",$P(N0,U,4),$P(N0,U,2),$P(N0,U,6),X,DA)
|
|
Q
|
|
;
|
|
S6 ; SET 'AH' X-REF -- CALLED FROM FIELD 3. TXT
|
|
; ACTUALLY WILL SET 'AF' X-REF.
|
|
N N0
|
|
S N0=$G(^PRC(443.75,DA,0))
|
|
I $P(N0,U,2)]"",$P(N0,U,3)]"",$P(N0,U,6)]"",X="TXT" S ^PRC(443.75,"AF",X,$P(N0,U,2),$P(N0,U,6),$P(N0,U,3),DA)=""
|
|
Q
|
|
;
|
|
K6 ; KILL 'AH' X-REF -- CALLED FROM FIELD 3. TXT
|
|
; ACTUALLY WILL KILL 'AF' X-REF.
|
|
N N0
|
|
S N0=$G(^PRC(443.75,DA,0))
|
|
I $P(N0,U,2)]"",$P(N0,U,3)]"",$P(N0,U,6)]"",X="TXT" K ^PRC(443.75,"AF",X,$P(N0,U,2),$P(N0,U,6),$P(N0,U,3),DA)
|
|
Q
|
|
;
|
|
S7 ; SET 'AI' X-REF -- CALLED FROM FIELD 5. TXT
|
|
; ACTUALLY WILL SET 'AF' X-REF.
|
|
N N0
|
|
S N0=$G(^PRC(443.75,DA,0))
|
|
I $P(N0,U,2)]"",$P(N0,U,3)]"",$P(N0,U,4)="TXT" S ^PRC(443.75,"AF",$P(N0,U,4),$P(N0,U,2),X,$P(N0,U,3),DA)=""
|
|
Q
|
|
;
|
|
K7 ; KILL 'AI' X-REF -- CALLED FROM FIELD 5. TXT
|
|
; ACTUALLY WILL KILL 'AF' X-REF.
|
|
N N0
|
|
S N0=$G(^PRC(443.75,DA,0))
|
|
I $P(N0,U,2)]"",$P(N0,U,3)]"",$P(N0,U,4)="TXT" K ^PRC(443.75,"AF",$P(N0,U,4),$P(N0,U,2),X,$P(N0,U,3),X,DA)
|
|
Q
|
|
;
|
|
S8 ; SET 'AN' X-REF -- CALLED FROM FIELD 6.5. RFQ
|
|
; ACTUALLY WILL SET 'AC' X-REF.
|
|
N N0
|
|
S N0=$G(^PRC(443.75,DA,0))
|
|
I $P(N0,U,2)]"",$P(N0,U,4)="RFQ",$P(N0,U,6)]"" S ^PRC(443.75,"AC",$P(N0,U,4),$P(N0,U,2),$P(N0,U,6),X,DA)=""
|
|
Q
|
|
;
|
|
K8 ; KILL 'AN' X-REF -- CALLED FROM FIELD 6.5. RFQ
|
|
; ACTUALLY WILL KILL 'AC' X-REF.
|
|
N N0
|
|
S N0=$G(^PRC(443.75,DA,0))
|
|
I $P(N0,U,2)]"",$P(N0,U,4)="RFQ",$P(N0,U,6)]"" K ^PRC(443.75,"AC",$P(N0,U,4),$P(N0,U,2),$P(N0,U,6),X,DA)
|
|
Q
|
|
;
|
|
S9 ; SET 'AO' X-REF -- CALLED FROM FIELD 1. PHA
|
|
N N0
|
|
S N0=$G(^PRC(443.75,DA,0))
|
|
I $P(N0,U,4)="PHA",$P(N0,U,6)]"" S ^PRC(443.75,"AO",$P(N0,U,4),X,$P(N0,U,6),DA)=""
|
|
Q
|
|
;
|
|
K9 ; KILL 'AO' X-REF -- CALLED FROM FIELD 1. PHA
|
|
N N0
|
|
S N0=$G(^PRC(443.75,DA,0))
|
|
I $P(N0,U,4)="PHA",$P(N0,U,6)]"" K ^PRC(443.75,"AO",$P(N0,U,4),X,$P(N0,U,6),DA)
|
|
Q
|
|
;
|
|
S10 ; SET 'AP' X-REF -- CALLED FROM FIELD 3. PHA
|
|
; ACTUALLY WILL SET 'AO' X-REF.
|
|
N N0
|
|
S N0=$G(^PRC(443.75,DA,0))
|
|
I X="PHA",$P(N0,U,2)]"",$P(N0,U,6)]"" S ^PRC(443.75,"AO",X,$P(N0,U,2),$P(N0,U,6),DA)=""
|
|
Q
|
|
;
|
|
K10 ; KILL 'AP' X-REF -- CALLED FROM FIELD 3. PHA
|
|
; ACTUALLY WILL KILL 'AO' X-REF.
|
|
N N0
|
|
S N0=$G(^PRC(443.75,DA,0))
|
|
I X="PHA",$P(N0,U,2)]"",$P(N0,U,6)]"" K ^PRC(443.75,"AO",X,$P(N0,U,2),$P(N0,U,6),DA)
|
|
Q
|
|
;
|
|
S11 ; SET 'AQ' X-REF -- CALLED FROM FIELD 5. PHA
|
|
; ACTUALLY WILL SET 'AO' X-REF.
|
|
N N0
|
|
S N0=$G(^PRC(443.75,DA,0))
|
|
I $P(N0,U,2)]"",$P(N0,U,4)="PHA" S ^PRC(443.75,"AO",$P(N0,U,4),$P(N0,U,2),X,DA)=""
|
|
Q
|
|
;
|
|
K11 ; KILL 'AQ' X-REF -- CALLED FROM FIELD 5. PHA
|
|
; ACTUALLY WILL KILL 'AO' X-REF.
|
|
N N0
|
|
S N0=$G(^PRC(443.75,DA,0))
|
|
I $P(N0,U,2)]"",$P(N0,U,4)="PHA" K ^PRC(443.75,"AO",$P(N0,U,4),$P(N0,U,2),X,DA)
|
|
Q
|
|
;
|
|
S12 ; SET 'AL' X-REF FOR ALL ACCEPTED OR REJECTED TRANSACTIONS.
|
|
; CALLED FROM FIELD 10.
|
|
;
|
|
; SEE IF FIELD 24 IS SET. IF SO DON'T SET THIS X-REF.
|
|
;
|
|
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,"AL",Z17,Z1,+$E(X,1,30),DA)=""
|
|
. ;
|
|
. ; NOW KILL 'AJ' 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 "AJ" IS THE LEVEL.
|
|
. ;
|
|
. K:Z4]""&(Z7>0) ^PRC(443.75,"AJ",1,Z4,+$E(Z7,1,30),DA)
|
|
. Q
|
|
K Z0,Z1,Z4,Z7,Z17
|
|
Q
|
|
;
|
|
K12 ; KILL 'AL' X-REF FOR ALL ACCEPTED OR REJECTED TRANSACTIONS.
|
|
; CALLED FROM FIELD 10.
|
|
;
|
|
S Z0=$G(^PRC(443.75,DA,1))
|
|
S Z17=$P(Z0,U,17)
|
|
S Z1=$P(Z0,U)
|
|
I Z17=2&(Z1]"") D
|
|
. K ^PRC(443.75,"AL",2,Z1,+$E(X,1,30),DA)
|
|
. ;
|
|
. ; NOW LETS RESTORE 'AJ' 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 "AJ" IS THE LEVEL.
|
|
. ;
|
|
. S:Z4]""&(Z7>0) ^PRC(443.75,"AJ",1,Z4,+$E(Z7,1,30),DA)=""
|
|
. Q
|
|
K Z0,Z1,Z4,Z7
|
|
Q
|
|
;
|
|
S13 ; SET 'AM' X-REF FOR ALL POA TRANSACTIONS.
|
|
; CALLED FROM FIELD 24.
|
|
;
|
|
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 Z17=3&(Z15]"") D
|
|
. S ^PRC(443.75,"AM",3,Z15,+$E(X,1,30),DA)=""
|
|
. ;
|
|
. ; NOW KILL 'AL' X-REF FOR THIS RECORD.
|
|
. ; THE 2 AFTER "AL" IS THE LEVEL.
|
|
. ;
|
|
. K:Z1]""&(Z2>0) ^PRC(443.75,"AL",2,Z1,+$E(Z2,1,30),DA)
|
|
. Q
|
|
K Z0,Z1,Z2,Z15
|
|
Q
|
|
;
|
|
K13 ; KILL 'AM' X-REF FOR ALL POA TRANSACTIONS.
|
|
; CALLED FROM FIELD 24.
|
|
;
|
|
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,"AM",Z17,Z15,+$E(X,1,30),DA)
|
|
. ;
|
|
. ; NOW SET 'AL' X-REF FOR THIS RECORD.
|
|
. ; THE 2 AFTER "AL" IS THE LEVEL.
|
|
. ;
|
|
. S:Z1]""&(Z2>0) ^PRC(443.75,"AL",2,Z1,+$E(Z2,1,30),DA)=""
|
|
. Q
|
|
K Z0,Z1,Z2,Z15
|
|
Q
|