- 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 Jan 18, 2025@03:17:45 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