DVBCPNCS ;ALB/BG;PNCS DBQ UTILITY RPC ; 5/7/21 8:48am
;;2.7;AMIE;**226**;Apr 10, 1995;Build 18
;Per VHA Directive 6402 this routine should not be modified
;
Q
;
ACTIVE(DVBRTN) ;
N DVBIEN,DVBCTR,DVBNM,DVBPROD,DVBVER,DVBPNFL
S DVBCTR=0
S DVBIEN=0 F S DVBIEN=$O(^DVB(396.18,DVBIEN)) Q:'DVBIEN D
.Q:$P($G(^DVB(396.18,DVBIEN,4)),U,1)=9
.Q:$P($G(^DVB(396.18,DVBIEN,2)),U,2)'=""
.Q:$P($G(^DVB(396.18,DVBIEN,2)),U,1)=""
.S DVBCTR=DVBCTR+1
.S DVBNM=$P($P($G(^DVB(396.18,DVBIEN,0)),U,1),"~",1)
.S DVBPROD=$$FMTE^XLFDT($P($G(^DVB(396.18,DVBIEN,2)),U))
.S DVBVER=$P($G(^DVB(396.18,DVBIEN,0)),"~",2)
.S DVBPNFL=$P($G(^DVB(396.18,DVBIEN,3,1,0))," ",3)
.S DVBRTN(DVBCTR)=$G(DVBNM)_"^"_$G(DVBPROD)_"^"_$G(DVBVER)_"^"_$G(DVBPNFL)
Q
;
DBQCHECK(DVBRTN,DVBIEN) ;
N DVBDBQ,DVBCTR,DVBCT,DVBSTAT
S DVBCTR=0
I $G(DVBIEN)="" S DVBRTN="FALSE" Q
S DVBCT=0 F S DVBCT=$O(^DVB(396.17,$G(DVBIEN),1,DVBCT)) Q:'DVBCT D
.S DVBCTR=DVBCTR+1
.S DVBDBQ=$P(^DVB(396.17,$G(DVBIEN),1,DVBCT,0),U)
.S DVBSTAT=$S($P($G(^DVB(396.18,DVBDBQ,2)),U,2)="":"TRUE",1:"FALSE")
.I DVBSTAT="FALSE" S DIE="^DVB(396.17,",DR="11///O",DA=DVBIEN D ^DIE
.S DVBRTN(DVBCTR)=$G(DVBSTAT)_"^"_$P(^DVB(396.17,$G(DVBIEN),1,DVBCT,0),U,2)
Q
;
DBQSTAT(DVBRTN,DVBIEN,DVBSTAT) ;
I $G(DVBIEN)="" S DVBRTN="-1" Q
I $G(DVBSTAT)="" S DVBRTN="-1" Q
S $P(^DVB(396.17,DVBIEN,5),U,2)=DVBSTAT
S DVBRTN="1"
Q
;
DBQCK(DVBRTN,DVBDBQ,DVBDATE) ;
N DVBDDIFF,DVBDACT,DVBFLAG,DVBDT,DVBIEN,DVBYR,DVBACDT,DVBDIFF,DVBCNT,DVBNM
I '$D(DVBDBQ) Q
I '$D(DVBDATE) Q
S DVBFLAG=0,DVBCNT=0
S DVBDATE=$TR($E($P(DVBDATE,"T"),1,100),"-") S DVBYR=$E(DVBDATE,1,4)-1700
S DVBDATE=DVBYR_$E(DVBDATE,5,100)
S DVBDBQ=$TR(DVBDBQ,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
S DVBIEN=0 F S DVBIEN=$O(^DVB(396.18,DVBIEN)) Q:'DVBIEN D
.N DVBDIFF,DVBDDIFF,DVBDACT,DVBDACT
.S DVBNM=$P($P($G(^DVB(396.18,DVBIEN,0)),U,1),"~",1)
.I DVBNM'[DVBDBQ Q
.S DVBDACT=$P($G(^DVB(396.18,DVBIEN,2)),U,2)
.S DVBACDT=$P($G(^DVB(396.18,DVBIEN,2)),U)
.S DVBDIFF=$$FMDIFF^XLFDT(DVBDATE,DVBACDT)
.I DVBDACT'="" S DVBDDIFF=$$FMDIFF^XLFDT(DVBDATE,DVBDACT)
.I DVBDACT="",DVBDIFF'["-" S DVBRTN="TRUE" Q
.I DVBDIFF["-" S DVBRTN="FALSE" Q
.I DVBDACT'="" S DVBRTN="FALSE" Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCPNCS 2266 printed Dec 13, 2024@01:45:14 Page 2
DVBCPNCS ;ALB/BG;PNCS DBQ UTILITY RPC ; 5/7/21 8:48am
+1 ;;2.7;AMIE;**226**;Apr 10, 1995;Build 18
+2 ;Per VHA Directive 6402 this routine should not be modified
+3 ;
+4 QUIT
+5 ;
ACTIVE(DVBRTN) ;
+1 NEW DVBIEN,DVBCTR,DVBNM,DVBPROD,DVBVER,DVBPNFL
+2 SET DVBCTR=0
+3 SET DVBIEN=0
FOR
SET DVBIEN=$ORDER(^DVB(396.18,DVBIEN))
if 'DVBIEN
QUIT
Begin DoDot:1
+4 if $PIECE($GET(^DVB(396.18,DVBIEN,4)),U,1)=9
QUIT
+5 if $PIECE($GET(^DVB(396.18,DVBIEN,2)),U,2)'=""
QUIT
+6 if $PIECE($GET(^DVB(396.18,DVBIEN,2)),U,1)=""
QUIT
+7 SET DVBCTR=DVBCTR+1
+8 SET DVBNM=$PIECE($PIECE($GET(^DVB(396.18,DVBIEN,0)),U,1),"~",1)
+9 SET DVBPROD=$$FMTE^XLFDT($PIECE($GET(^DVB(396.18,DVBIEN,2)),U))
+10 SET DVBVER=$PIECE($GET(^DVB(396.18,DVBIEN,0)),"~",2)
+11 SET DVBPNFL=$PIECE($GET(^DVB(396.18,DVBIEN,3,1,0))," ",3)
+12 SET DVBRTN(DVBCTR)=$GET(DVBNM)_"^"_$GET(DVBPROD)_"^"_$GET(DVBVER)_"^"_$GET(DVBPNFL)
End DoDot:1
+13 QUIT
+14 ;
DBQCHECK(DVBRTN,DVBIEN) ;
+1 NEW DVBDBQ,DVBCTR,DVBCT,DVBSTAT
+2 SET DVBCTR=0
+3 IF $GET(DVBIEN)=""
SET DVBRTN="FALSE"
QUIT
+4 SET DVBCT=0
FOR
SET DVBCT=$ORDER(^DVB(396.17,$GET(DVBIEN),1,DVBCT))
if 'DVBCT
QUIT
Begin DoDot:1
+5 SET DVBCTR=DVBCTR+1
+6 SET DVBDBQ=$PIECE(^DVB(396.17,$GET(DVBIEN),1,DVBCT,0),U)
+7 SET DVBSTAT=$SELECT($PIECE($GET(^DVB(396.18,DVBDBQ,2)),U,2)="":"TRUE",1:"FALSE")
+8 IF DVBSTAT="FALSE"
SET DIE="^DVB(396.17,"
SET DR="11///O"
SET DA=DVBIEN
DO ^DIE
+9 SET DVBRTN(DVBCTR)=$GET(DVBSTAT)_"^"_$PIECE(^DVB(396.17,$GET(DVBIEN),1,DVBCT,0),U,2)
End DoDot:1
+10 QUIT
+11 ;
DBQSTAT(DVBRTN,DVBIEN,DVBSTAT) ;
+1 IF $GET(DVBIEN)=""
SET DVBRTN="-1"
QUIT
+2 IF $GET(DVBSTAT)=""
SET DVBRTN="-1"
QUIT
+3 SET $PIECE(^DVB(396.17,DVBIEN,5),U,2)=DVBSTAT
+4 SET DVBRTN="1"
+5 QUIT
+6 ;
DBQCK(DVBRTN,DVBDBQ,DVBDATE) ;
+1 NEW DVBDDIFF,DVBDACT,DVBFLAG,DVBDT,DVBIEN,DVBYR,DVBACDT,DVBDIFF,DVBCNT,DVBNM
+2 IF '$DATA(DVBDBQ)
QUIT
+3 IF '$DATA(DVBDATE)
QUIT
+4 SET DVBFLAG=0
SET DVBCNT=0
+5 SET DVBDATE=$TRANSLATE($EXTRACT($PIECE(DVBDATE,"T"),1,100),"-")
SET DVBYR=$EXTRACT(DVBDATE,1,4)-1700
+6 SET DVBDATE=DVBYR_$EXTRACT(DVBDATE,5,100)
+7 SET DVBDBQ=$TRANSLATE(DVBDBQ,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+8 SET DVBIEN=0
FOR
SET DVBIEN=$ORDER(^DVB(396.18,DVBIEN))
if 'DVBIEN
QUIT
Begin DoDot:1
+9 NEW DVBDIFF,DVBDDIFF,DVBDACT,DVBDACT
+10 SET DVBNM=$PIECE($PIECE($GET(^DVB(396.18,DVBIEN,0)),U,1),"~",1)
+11 IF DVBNM'[DVBDBQ
QUIT
+12 SET DVBDACT=$PIECE($GET(^DVB(396.18,DVBIEN,2)),U,2)
+13 SET DVBACDT=$PIECE($GET(^DVB(396.18,DVBIEN,2)),U)
+14 SET DVBDIFF=$$FMDIFF^XLFDT(DVBDATE,DVBACDT)
+15 IF DVBDACT'=""
SET DVBDDIFF=$$FMDIFF^XLFDT(DVBDATE,DVBDACT)
+16 IF DVBDACT=""
IF DVBDIFF'["-"
SET DVBRTN="TRUE"
QUIT
+17 IF DVBDIFF["-"
SET DVBRTN="FALSE"
QUIT
+18 IF DVBDACT'=""
SET DVBRTN="FALSE"
QUIT
End DoDot:1
+19 QUIT
