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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCOEDIS 7051 printed Nov 22, 2024@17:21:58 Page 2
PRCOEDIS ;WISC/DJM-IFCAP X-REF ROUTINE FOR FILE 443.75 ; [8/31/98 1:24pm]
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
S1 ; SET 'AC' X-REF -- CALLED FROM FIELD 1. RFQ
+1 NEW N0
+2 SET N0=$GET(^PRC(443.75,DA,0))
+3 IF $PIECE(N0,U,4)="RFQ"
IF $PIECE(N0,U,6)]""
IF $PIECE(N0,U,10)]""
SET ^PRC(443.75,"AC",$PIECE(N0,U,4),X,$PIECE(N0,U,6),$PIECE(N0,U,10),DA)=""
+4 QUIT
+5 ;
K1 ; KILL 'AC' X-REF -- CALLED FROM FIELD 1. RFQ
+1 NEW N0
+2 SET N0=$GET(^PRC(443.75,DA,0))
+3 IF $PIECE(N0,U,4)="RFQ"
IF $PIECE(N0,U,6)]""
IF $PIECE(N0,U,10)]""
KILL ^PRC(443.75,"AC",$PIECE(N0,U,4),X,$PIECE(N0,U,6),$PIECE(N0,U,10),DA)
+4 QUIT
+5 ;
S2 ; SET 'AD' X-REF -- CALLED FROM FIELD 3. RFQ
+1 ; ACTUALLY WILL SET 'AC' X-REF.
+2 NEW N0
+3 SET N0=$GET(^PRC(443.75,DA,0))
+4 IF $PIECE(N0,U,2)]""
IF $PIECE(N0,U,6)]""
IF $PIECE(N0,U,10)]""
IF X="RFQ"
SET ^PRC(443.75,"AC",X,$PIECE(N0,U,2),$PIECE(N0,U,6),$PIECE(N0,U,10),DA)=""
+5 QUIT
+6 ;
K2 ; KILL 'AD' X-REF -- CALLED FROM FIELD 3. RFQ
+1 ; ACTUALLY WILL KILL 'AC' X-REF.
+2 NEW N0
+3 SET N0=$GET(^PRC(443.75,DA,0))
+4 IF $PIECE(N0,U,2)]""
IF $PIECE(N0,U,6)]""
IF $PIECE(N0,U,10)]""
IF X="RFQ"
KILL ^PRC(443.75,"AC",X,$PIECE(N0,U,2),$PIECE(N0,U,6),$PIECE(N0,U,10),DA)
+5 QUIT
+6 ;
S3 ; SET 'AE' X-REF -- CALLED FROM FIELD 5. RFQ
+1 ; ACTUALLY WILL SET 'AC' X-REF.
+2 NEW N0
+3 SET N0=$GET(^PRC(443.75,DA,0))
+4 IF $PIECE(N0,U,2)]""
IF $PIECE(N0,U,4)="RFQ"
IF $PIECE(N0,U,10)]""
SET ^PRC(443.75,"AC",$PIECE(N0,U,4),$PIECE(N0,U,2),X,$PIECE(N0,U,10),DA)=""
+5 QUIT
+6 ;
K3 ; KILL 'AE' X-REF -- CALLED FROM FIELD 5. RFQ
+1 ; ACTUALLY WILL KILL 'AC' X-REF.
+2 NEW N0
+3 SET N0=$GET(^PRC(443.75,DA,0))
+4 IF $PIECE(N0,U,2)]""
IF $PIECE(N0,U,4)="RFQ"
IF $PIECE(N0,U,10)]""
KILL ^PRC(443.75,"AC",$PIECE(N0,U,4),$PIECE(N0,U,2),X,$PIECE(N0,U,10),DA)
+5 QUIT
+6 ;
S4 ; SET 'AF' X-REF -- CALLED FROM FIELD 1. TXT
+1 NEW N0
+2 SET N0=$GET(^PRC(443.75,DA,0))
+3 IF $PIECE(N0,U,3)]""
IF $PIECE(N0,U,4)="TXT"
IF $PIECE(N0,U,6)]""
SET ^PRC(443.75,"AF",$PIECE(N0,U,4),X,$PIECE(N0,U,6),$PIECE(N0,U,3),DA)=""
+4 QUIT
+5 ;
K4 ; KILL 'AF' X-REF -- CALLED FROM FIELD 1. TXT
+1 NEW N0
+2 SET N0=$GET(^PRC(443.75,DA,0))
+3 IF $PIECE(N0,U,3)]""
IF $PIECE(N0,U,4)="TXT"
IF $PIECE(N0,U,6)]""
KILL ^PRC(443.75,"AF",$PIECE(N0,U,4),X,$PIECE(N0,U,6),$PIECE(N0,U,3),DA)
+4 QUIT
+5 ;
S5 ; SET 'AG' X-REF -- CALLED FROM FIELD 2. TXT
+1 ; ACTUALLY WILL SET 'AF' X-REF.
+2 NEW N0
+3 SET N0=$GET(^PRC(443.75,DA,0))
+4 IF $PIECE(N0,U,2)]""
IF $PIECE(N0,U,4)="TXT"
IF $PIECE(N0,U,6)]""
SET ^PRC(443.75,"AF",$PIECE(N0,U,4),$PIECE(N0,U,2),$PIECE(N0,U,6),X,DA)=""
+5 QUIT
+6 ;
K5 ; KILL 'AG' X-REF -- CALLED FROM FIELD 2. TXT
+1 ; ACTUALLY WILL KILL 'AF' X-REF.
+2 NEW N0
+3 SET N0=$GET(^PRC(443.75,DA,0))
+4 IF $PIECE(N0,U,2)]""
IF $PIECE(N0,U,4)="TXT"
IF $PIECE(N0,U,6)]""
KILL ^PRC(443.75,"AF",$PIECE(N0,U,4),$PIECE(N0,U,2),$PIECE(N0,U,6),X,DA)
+5 QUIT
+6 ;
S6 ; SET 'AH' X-REF -- CALLED FROM FIELD 3. TXT
+1 ; ACTUALLY WILL SET 'AF' X-REF.
+2 NEW N0
+3 SET N0=$GET(^PRC(443.75,DA,0))
+4 IF $PIECE(N0,U,2)]""
IF $PIECE(N0,U,3)]""
IF $PIECE(N0,U,6)]""
IF X="TXT"
SET ^PRC(443.75,"AF",X,$PIECE(N0,U,2),$PIECE(N0,U,6),$PIECE(N0,U,3),DA)=""
+5 QUIT
+6 ;
K6 ; KILL 'AH' X-REF -- CALLED FROM FIELD 3. TXT
+1 ; ACTUALLY WILL KILL 'AF' X-REF.
+2 NEW N0
+3 SET N0=$GET(^PRC(443.75,DA,0))
+4 IF $PIECE(N0,U,2)]""
IF $PIECE(N0,U,3)]""
IF $PIECE(N0,U,6)]""
IF X="TXT"
KILL ^PRC(443.75,"AF",X,$PIECE(N0,U,2),$PIECE(N0,U,6),$PIECE(N0,U,3),DA)
+5 QUIT
+6 ;
S7 ; SET 'AI' X-REF -- CALLED FROM FIELD 5. TXT
+1 ; ACTUALLY WILL SET 'AF' X-REF.
+2 NEW N0
+3 SET N0=$GET(^PRC(443.75,DA,0))
+4 IF $PIECE(N0,U,2)]""
IF $PIECE(N0,U,3)]""
IF $PIECE(N0,U,4)="TXT"
SET ^PRC(443.75,"AF",$PIECE(N0,U,4),$PIECE(N0,U,2),X,$PIECE(N0,U,3),DA)=""
+5 QUIT
+6 ;
K7 ; KILL 'AI' X-REF -- CALLED FROM FIELD 5. TXT
+1 ; ACTUALLY WILL KILL 'AF' X-REF.
+2 NEW N0
+3 SET N0=$GET(^PRC(443.75,DA,0))
+4 IF $PIECE(N0,U,2)]""
IF $PIECE(N0,U,3)]""
IF $PIECE(N0,U,4)="TXT"
KILL ^PRC(443.75,"AF",$PIECE(N0,U,4),$PIECE(N0,U,2),X,$PIECE(N0,U,3),X,DA)
+5 QUIT
+6 ;
S8 ; SET 'AN' X-REF -- CALLED FROM FIELD 6.5. RFQ
+1 ; ACTUALLY WILL SET 'AC' X-REF.
+2 NEW N0
+3 SET N0=$GET(^PRC(443.75,DA,0))
+4 IF $PIECE(N0,U,2)]""
IF $PIECE(N0,U,4)="RFQ"
IF $PIECE(N0,U,6)]""
SET ^PRC(443.75,"AC",$PIECE(N0,U,4),$PIECE(N0,U,2),$PIECE(N0,U,6),X,DA)=""
+5 QUIT
+6 ;
K8 ; KILL 'AN' X-REF -- CALLED FROM FIELD 6.5. RFQ
+1 ; ACTUALLY WILL KILL 'AC' X-REF.
+2 NEW N0
+3 SET N0=$GET(^PRC(443.75,DA,0))
+4 IF $PIECE(N0,U,2)]""
IF $PIECE(N0,U,4)="RFQ"
IF $PIECE(N0,U,6)]""
KILL ^PRC(443.75,"AC",$PIECE(N0,U,4),$PIECE(N0,U,2),$PIECE(N0,U,6),X,DA)
+5 QUIT
+6 ;
S9 ; SET 'AO' X-REF -- CALLED FROM FIELD 1. PHA
+1 NEW N0
+2 SET N0=$GET(^PRC(443.75,DA,0))
+3 IF $PIECE(N0,U,4)="PHA"
IF $PIECE(N0,U,6)]""
SET ^PRC(443.75,"AO",$PIECE(N0,U,4),X,$PIECE(N0,U,6),DA)=""
+4 QUIT
+5 ;
K9 ; KILL 'AO' X-REF -- CALLED FROM FIELD 1. PHA
+1 NEW N0
+2 SET N0=$GET(^PRC(443.75,DA,0))
+3 IF $PIECE(N0,U,4)="PHA"
IF $PIECE(N0,U,6)]""
KILL ^PRC(443.75,"AO",$PIECE(N0,U,4),X,$PIECE(N0,U,6),DA)
+4 QUIT
+5 ;
S10 ; SET 'AP' X-REF -- CALLED FROM FIELD 3. PHA
+1 ; ACTUALLY WILL SET 'AO' X-REF.
+2 NEW N0
+3 SET N0=$GET(^PRC(443.75,DA,0))
+4 IF X="PHA"
IF $PIECE(N0,U,2)]""
IF $PIECE(N0,U,6)]""
SET ^PRC(443.75,"AO",X,$PIECE(N0,U,2),$PIECE(N0,U,6),DA)=""
+5 QUIT
+6 ;
K10 ; KILL 'AP' X-REF -- CALLED FROM FIELD 3. PHA
+1 ; ACTUALLY WILL KILL 'AO' X-REF.
+2 NEW N0
+3 SET N0=$GET(^PRC(443.75,DA,0))
+4 IF X="PHA"
IF $PIECE(N0,U,2)]""
IF $PIECE(N0,U,6)]""
KILL ^PRC(443.75,"AO",X,$PIECE(N0,U,2),$PIECE(N0,U,6),DA)
+5 QUIT
+6 ;
S11 ; SET 'AQ' X-REF -- CALLED FROM FIELD 5. PHA
+1 ; ACTUALLY WILL SET 'AO' X-REF.
+2 NEW N0
+3 SET N0=$GET(^PRC(443.75,DA,0))
+4 IF $PIECE(N0,U,2)]""
IF $PIECE(N0,U,4)="PHA"
SET ^PRC(443.75,"AO",$PIECE(N0,U,4),$PIECE(N0,U,2),X,DA)=""
+5 QUIT
+6 ;
K11 ; KILL 'AQ' X-REF -- CALLED FROM FIELD 5. PHA
+1 ; ACTUALLY WILL KILL 'AO' X-REF.
+2 NEW N0
+3 SET N0=$GET(^PRC(443.75,DA,0))
+4 IF $PIECE(N0,U,2)]""
IF $PIECE(N0,U,4)="PHA"
KILL ^PRC(443.75,"AO",$PIECE(N0,U,4),$PIECE(N0,U,2),X,DA)
+5 QUIT
+6 ;
S12 ; SET 'AL' X-REF FOR ALL ACCEPTED OR REJECTED TRANSACTIONS.
+1 ; CALLED FROM FIELD 10.
+2 ;
+3 ; SEE IF FIELD 24 IS SET. IF SO DON'T SET THIS X-REF.
+4 ;
+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 SET ^PRC(443.75,"AL",Z17,Z1,+$EXTRACT(X,1,30),DA)=""
+10 ;
+11 ; NOW KILL 'AJ' 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 ;
+17 ; THE 1 AFTER "AJ" IS THE LEVEL.
+18 ;
+19 if Z4]""&(Z7>0)
KILL ^PRC(443.75,"AJ",1,Z4,+$EXTRACT(Z7,1,30),DA)
+20 QUIT
End DoDot:1
+21 KILL Z0,Z1,Z4,Z7,Z17
+22 QUIT
+23 ;
K12 ; KILL 'AL' X-REF FOR ALL ACCEPTED OR REJECTED TRANSACTIONS.
+1 ; CALLED FROM FIELD 10.
+2 ;
+3 SET Z0=$GET(^PRC(443.75,DA,1))
+4 SET Z17=$PIECE(Z0,U,17)
+5 SET Z1=$PIECE(Z0,U)
+6 IF Z17=2&(Z1]"")
Begin DoDot:1
+7 KILL ^PRC(443.75,"AL",2,Z1,+$EXTRACT(X,1,30),DA)
+8 ;
+9 ; NOW LETS RESTORE 'AJ' X-REF FOR THIS RECORD.
+10 ;
+11 SET Z0=$GET(^PRC(443.75,DA,0))
+12 SET Z4=$PIECE(Z0,U,4)
+13 SET Z7=$PIECE(Z0,U,7)
+14 ;
+15 ; THE 1 AFTER "AJ" IS THE LEVEL.
+16 ;
+17 if Z4]""&(Z7>0)
SET ^PRC(443.75,"AJ",1,Z4,+$EXTRACT(Z7,1,30),DA)=""
+18 QUIT
End DoDot:1
+19 KILL Z0,Z1,Z4,Z7
+20 QUIT
+21 ;
S13 ; SET 'AM' X-REF FOR ALL POA TRANSACTIONS.
+1 ; CALLED FROM FIELD 24.
+2 ;
+3 SET Z0=$GET(^PRC(443.75,DA,1))
+4 SET Z1=$PIECE(Z0,U)
+5 SET Z2=$PIECE(Z0,U,2)
+6 SET Z15=$PIECE(Z0,U,15)
+7 SET Z17=$PIECE(Z0,U,17)
+8 IF Z17=3&(Z15]"")
Begin DoDot:1
+9 SET ^PRC(443.75,"AM",3,Z15,+$EXTRACT(X,1,30),DA)=""
+10 ;
+11 ; NOW KILL 'AL' X-REF FOR THIS RECORD.
+12 ; THE 2 AFTER "AL" IS THE LEVEL.
+13 ;
+14 if Z1]""&(Z2>0)
KILL ^PRC(443.75,"AL",2,Z1,+$EXTRACT(Z2,1,30),DA)
+15 QUIT
End DoDot:1
+16 KILL Z0,Z1,Z2,Z15
+17 QUIT
+18 ;
K13 ; KILL 'AM' X-REF FOR ALL POA TRANSACTIONS.
+1 ; CALLED FROM FIELD 24.
+2 ;
+3 SET Z0=$GET(^PRC(443.75,DA,1))
+4 SET Z1=$PIECE(Z0,U)
+5 SET Z2=$PIECE(Z0,U,2)
+6 SET Z15=$PIECE(Z0,U,15)
+7 SET Z17=$PIECE(Z0,U,17)
+8 IF Z15]""&(Z17=3)
Begin DoDot:1
+9 KILL ^PRC(443.75,"AM",Z17,Z15,+$EXTRACT(X,1,30),DA)
+10 ;
+11 ; NOW SET 'AL' X-REF FOR THIS RECORD.
+12 ; THE 2 AFTER "AL" IS THE LEVEL.
+13 ;
+14 if Z1]""&(Z2>0)
SET ^PRC(443.75,"AL",2,Z1,+$EXTRACT(Z2,1,30),DA)=""
+15 QUIT
End DoDot:1
+16 KILL Z0,Z1,Z2,Z15
+17 QUIT
