- 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 Feb 18, 2025@23:11:38 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
