PRCPUXRE.m

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 ---PRCPUXRE   1308     printed  Apr 09, 2024@21:21:50                                                                                                                                                                                                    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