PRCPUXRE ;WISC/RFJ-xref for file 445.2 and 445.3 ;24 May 93
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
XREFAX(DA,X,FIELD,SETKILL) ; build xref for 445.2
; da = internal entry number
; x = value of data in field
; field = field number for x
; setkill = "SET" to set; "KILL" (or anything other than set) to kill
N %,DATE,INVPT,TYPETRAN
S %=$G(^PRCP(445.2,DA,0)) I %="" Q
S INVPT=+$P(%,"^"),TYPETRAN=$P(%,"^",4),DATE=+$P($P(%,"^",17),".")
D
. I FIELD=.01 S INVPT=X Q
. I FIELD=2.5 S DATE=X Q
. I FIELD=3 S TYPETRAN=X
I 'INVPT!(TYPETRAN="")!('DATE) Q
I SETKILL="SET" S ^PRCP(445.2,"AX",INVPT,DATE,TYPETRAN,DA)="" Q
K ^PRCP(445.2,"AX",INVPT,DATE,TYPETRAN,DA)
Q
;
;
XREFASR(DA,X,FIELD,SETKILL) ; build xref for file 445.3
; da = internal entry number
; x = value of data in field
; field = field number for x
; setkill = "SET" to set; "KILL" (or anything other than set) to kill
N %,PATDA,SURGDA
S %=$G(^PRCP(445.3,DA,2)) I %="" Q
S PATDA=+$P(%,"^"),SURGDA=+$P(%,"^",2)
D
. I FIELD=129 S PATDA=X Q
. I FIELD=130 S SURGDA=X Q
I 'PATDA!('SURGDA) Q
I SETKILL="SET" S ^PRCP(445.3,"ASR",PATDA,SURGDA,DA)="" Q
K ^PRCP(445.3,"ASR",PATDA,SURGDA,DA)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPUXRE 1308 printed Dec 13, 2024@02:16:33 Page 2
PRCPUXRE ;WISC/RFJ-xref for file 445.2 and 445.3 ;24 May 93
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
XREFAX(DA,X,FIELD,SETKILL) ; build xref for 445.2
+1 ; da = internal entry number
+2 ; x = value of data in field
+3 ; field = field number for x
+4 ; setkill = "SET" to set; "KILL" (or anything other than set) to kill
+5 NEW %,DATE,INVPT,TYPETRAN
+6 SET %=$GET(^PRCP(445.2,DA,0))
IF %=""
QUIT
+7 SET INVPT=+$PIECE(%,"^")
SET TYPETRAN=$PIECE(%,"^",4)
SET DATE=+$PIECE($PIECE(%,"^",17),".")
+8 Begin DoDot:1
+9 IF FIELD=.01
SET INVPT=X
QUIT
+10 IF FIELD=2.5
SET DATE=X
QUIT
+11 IF FIELD=3
SET TYPETRAN=X
End DoDot:1
+12 IF 'INVPT!(TYPETRAN="")!('DATE)
QUIT
+13 IF SETKILL="SET"
SET ^PRCP(445.2,"AX",INVPT,DATE,TYPETRAN,DA)=""
QUIT
+14 KILL ^PRCP(445.2,"AX",INVPT,DATE,TYPETRAN,DA)
+15 QUIT
+16 ;
+17 ;
XREFASR(DA,X,FIELD,SETKILL) ; build xref for file 445.3
+1 ; da = internal entry number
+2 ; x = value of data in field
+3 ; field = field number for x
+4 ; setkill = "SET" to set; "KILL" (or anything other than set) to kill
+5 NEW %,PATDA,SURGDA
+6 SET %=$GET(^PRCP(445.3,DA,2))
IF %=""
QUIT
+7 SET PATDA=+$PIECE(%,"^")
SET SURGDA=+$PIECE(%,"^",2)
+8 Begin DoDot:1
+9 IF FIELD=129
SET PATDA=X
QUIT
+10 IF FIELD=130
SET SURGDA=X
QUIT
End DoDot:1
+11 IF 'PATDA!('SURGDA)
QUIT
+12 IF SETKILL="SET"
SET ^PRCP(445.3,"ASR",PATDA,SURGDA,DA)=""
QUIT
+13 KILL ^PRCP(445.3,"ASR",PATDA,SURGDA,DA)
+14 QUIT
