Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCPUXRE

PRCPUXRE.m

Go to the documentation of this file.
  1. PRCPUXRE ;WISC/RFJ-xref for file 445.2 and 445.3 ;24 May 93
  1. ;;5.1;IFCAP;;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. Q
  1. ;
  1. ;
  1. XREFAX(DA,X,FIELD,SETKILL) ; build xref for 445.2
  1. ; da = internal entry number
  1. ; x = value of data in field
  1. ; field = field number for x
  1. ; setkill = "SET" to set; "KILL" (or anything other than set) to kill
  1. N %,DATE,INVPT,TYPETRAN
  1. S %=$G(^PRCP(445.2,DA,0)) I %="" Q
  1. S INVPT=+$P(%,"^"),TYPETRAN=$P(%,"^",4),DATE=+$P($P(%,"^",17),".")
  1. D
  1. . I FIELD=.01 S INVPT=X Q
  1. . I FIELD=2.5 S DATE=X Q
  1. . I FIELD=3 S TYPETRAN=X
  1. I 'INVPT!(TYPETRAN="")!('DATE) Q
  1. I SETKILL="SET" S ^PRCP(445.2,"AX",INVPT,DATE,TYPETRAN,DA)="" Q
  1. K ^PRCP(445.2,"AX",INVPT,DATE,TYPETRAN,DA)
  1. Q
  1. ;
  1. ;
  1. XREFASR(DA,X,FIELD,SETKILL) ; build xref for file 445.3
  1. ; da = internal entry number
  1. ; x = value of data in field
  1. ; field = field number for x
  1. ; setkill = "SET" to set; "KILL" (or anything other than set) to kill
  1. N %,PATDA,SURGDA
  1. S %=$G(^PRCP(445.3,DA,2)) I %="" Q
  1. S PATDA=+$P(%,"^"),SURGDA=+$P(%,"^",2)
  1. D
  1. . I FIELD=129 S PATDA=X Q
  1. . I FIELD=130 S SURGDA=X Q
  1. I 'PATDA!('SURGDA) Q
  1. I SETKILL="SET" S ^PRCP(445.3,"ASR",PATDA,SURGDA,DA)="" Q
  1. K ^PRCP(445.3,"ASR",PATDA,SURGDA,DA)
  1. Q