Routine: PSBVPR

PSBVPR ;SLC/JLC,ASMR/BL- BCMA-VPR UTILITIES ; 10/16/15 1:54pm

 ;;3.0;BAR CODE MED ADMIN;**79**;Mar 2004;Build 172

 ;Per VA Directive 6402, this routine should not be modified.

ADMIN(RESULTS,PSBVDFN,PSBORDNO,PSBVADT) ;

 I $G(PSBVDFN)="" Q -1

 I $G(PSBORDNO)="" Q -2

 K ^TMP("PSB",$J) N PSBI,A,PSBA,S1,X1,X2,X

 I '$G(PSBVADT) D NOW^%DTC S PSBVADT=%

 D GETINFO

 S RESULTS=$O(PSBA(PSBVADT-.0001)) I 'RESULTS S X1=PSBVADT,X2=1 D C^%DTC S PSBVADT=X D GETINFO

 S RESULTS=$O(PSBA(PSBVADT-.0001))

GETINFO ;

 I PSBORDNO?.E1"U" D RPC^PSBVDLTB(,PSBVDFN,"UDTAB",PSBVADT) M ^TMP("PSBVPR",$J)=^TMP("PSB",$J,"UDTAB")

 I PSBORDNO?.E1"V" F PSBI="IVTAB","PBTAB" D RPC^PSBVDLTB(,PSBVDFN,PSBI,$G(PSBVADT)) M ^TMP("PSBVPR",$J)=^TMP("PSB",$J,PSBI)

 S S1=0 F  S S1=$O(^TMP("PSBVPR",$J,S1)) Q:'S1  D

 . S A=^TMP("PSBVPR",$J,S1) I $P(A,"^")'=PSBVDFN Q

 . I $P(A,"^",2)'=PSBORDNO Q

 . S PSBA($P(A,"^",14))=""

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBVPR   916     printed  Feb 18, 2025@23:07:49                                                                                                                                                                                                       Page 2

PSBVPR    ;SLC/JLC,ASMR/BL- BCMA-VPR UTILITIES ; 10/16/15 1:54pm

 +1       ;;3.0;BAR CODE MED ADMIN;**79**;Mar 2004;Build 172

 +2       ;Per VA Directive 6402, this routine should not be modified.

 +3       ;

 +4       ;

ADMIN(RESULTS,PSBVDFN,PSBORDNO,PSBVADT) ;

 +1        IF $GET(PSBVDFN)=""

               QUIT -1

 +2        IF $GET(PSBORDNO)=""

               QUIT -2

 +3        KILL ^TMP("PSB",$JOB)

           NEW PSBI,A,PSBA,S1,X1,X2,X

 +4        IF '$GET(PSBVADT)

               DO NOW^%DTC

               SET PSBVADT=%

 +5        DO GETINFO

 +6        SET RESULTS=$ORDER(PSBA(PSBVADT-.0001))

           IF 'RESULTS

               SET X1=PSBVADT

               SET X2=1

               DO C^%DTC

               SET PSBVADT=X

               DO GETINFO

 +7        SET RESULTS=$ORDER(PSBA(PSBVADT-.0001))

 +8        QUIT

GETINFO   ;

 +1        IF PSBORDNO?.E1"U"

               DO RPC^PSBVDLTB(,PSBVDFN,"UDTAB",PSBVADT)

               MERGE ^TMP("PSBVPR",$JOB)=^TMP("PSB",$JOB,"UDTAB")

 +2        IF PSBORDNO?.E1"V"

               FOR PSBI="IVTAB","PBTAB"

                   DO RPC^PSBVDLTB(,PSBVDFN,PSBI,$GET(PSBVADT))

                   MERGE ^TMP("PSBVPR",$JOB)=^TMP("PSB",$JOB,PSBI)

 +3        SET S1=0

FOR

               SET S1=$ORDER(^TMP("PSBVPR",$JOB,S1))

               if 'S1

                   QUIT

               Begin DoDot:1

 +4                SET A=^TMP("PSBVPR",$JOB,S1)

                   IF $PIECE(A,"^")'=PSBVDFN

                       QUIT

 +5                IF $PIECE(A,"^",2)'=PSBORDNO

                       QUIT

 +6                SET PSBA($PIECE(A,"^",14))=""

               End DoDot:1

 +7        QUIT

PSBVPR.m