DVBCCHKR ;ALB/GTS-557/THM-CHECK C&P REQUEST FOR CRITICAL DATA ; 3/20/19 7:56am
;;2.7;AMIE;**17,194,193,209**;Apr 10, 1995;Build 17
;
;** Version Changes
; 2.7 - GTS/C&P appt links report (Enhc 13)
;
S DVBCMAN="" G EN
;
CHECK N OLDX
S OLDX=X,DTA=^DVB(396.3,DA,0),DTB=$S($D(^DVB(396.3,DA,1)):^(1),1:"")
;RRA DVBA*194 priority of exam no longer populated so remove from validation list
;AJF;Request Status conversion
;Patch 209, reverting report screeing back to before 193
Q:($P(DTA,U,18)=6)!($P(DTA,U,18)=7) F XI=2,3,4,18 I $P(^DVB(396.3,DA,0),U,XI)="" S X=X_XI_U
I $P(DTB,U,4)="" S X=X_99_U
I $O(^DVB(396.4,"C",DA,0))="" S X=X_98_U ;no exams selected
S REQDA=DA,NAME=$P(^DPT(DFN,0),U,1) D:STYLEIND'="4" LINKCK
I OLDX'=X DO
.S:$E(X,$L(X))="^" X=$E(X,1,($L(X)-1))
.S X=X_";"_DA_"~"
I X]"" S ^TMP($J,NAME,DFN)=X
Q
;
PRINT D HDR S NAME=""
F XI=0:0 S NAME=$O(^TMP($J,NAME)) Q:NAME=""!($D(DVBCQUIT)) DO
.S (DVBAPC,DVBADTA)=""
.F DFN=0:0 S DFN=$O(^TMP($J,NAME,DFN)) Q:DFN=""!($D(DVBCQUIT)) DO
..I (IOST?1"C-".E),($Y>(IOSL-9)) D TERM^DVBCUTL3 S:$D(GETOUT) DVBCQUIT=""
..I '$D(DVBCQUIT) DO
...D:($Y>(IOSL-9)) HDR
...D NAMELN ;**Output name
...F DVBAPC=1:1 S DVBADTA=$P(^TMP($J,NAME,DFN),"~",DVBAPC) Q:DVBADTA="" DO
....W !
....S DTA=$P(DVBADTA,";",1),REQDA=$P(DVBADTA,";",2) ;**DVBADTA=Prob pce
....F DVBCX=1:1 S DVBAY=$P(DTA,U,DVBCX) Q:DVBAY=""!($D(DVBCQUIT)) I DVBAY]"" D PRINT1
.K DVBAPC,DVBADTA
I '$D(DVBCQUIT)&(IOST?1"C-".E) D TERM^DVBCUTL3 S:$D(GETOUT) DVBCQUIT=""
Q
;
PRINT1 I (IOST?1"C-".E),($Y>(IOSL-2)) D TERM^DVBCUTL3 S:$D(GETOUT) DVBCQUIT=""
I '$D(DVBCQUIT) DO
.I ($Y>(IOSL-2)) D HDR,NAMELN
.W ?50,$S(DVBAY=2:"Request date",DVBAY=3:"Regional office number",DVBAY=4:"Requester",DVBAY=10:"Priority of exam",DVBAY=18:"Request status",DVBAY=99:"Routing location",1:"")
.W:DVBAY=98 ?50,"** No exams selected **"
.W:DVBAY=199 ?50,"** No C&P Appt's linked **"
.W !
Q
;
EN D HOME^%ZIS S FF=IOF
W @FF,!!,"This report will check the 2507 REQUEST file for missing crucial data.",!!,"All requests will be checked and those found missing any of the following",!,"will be reported:",!!
W "1) Request date",!,"2) Regional office number",!,"3) Requester",!
W "4) Request status",!,"5) Routing location",!,"6) No exams selected"
D SETSTYLE
W:STYLEIND=4 !
W:STYLEIND'="4" !,"7) Requests older than 3 days without C&P Appt links ",!
W ! K PARAMDA
;
ASK W "Do you want to continue" S %=2 D YN^DICN G:$D(DTOUT) EXIT
I $D(%Y),%Y["?" W !!,"Enter Y to print the report or N to quit.",!! H 2 G ASK
I $D(%),%'=1 G EXIT
;
DEV W !! S %ZIS="AEQ" D ^%ZIS K %ZIS G:POP EXIT I $D(IO("Q")) S ZTIO=ION,ZTDESC="2507 exam integrity report",ZTRTN="GO^DVBCCHKR" F I="FF" S ZTSAVE(I)=""
I D ^%ZTLOAD W:$D(ZTSK) !!,"Request queued",!! G EXIT
;
GO D:'$D(STYLEIND) SETSTYLE
K ^TMP($J),LN,DVBCQUIT,GETOUT S (ITEMS,PG)=0,$P(LN,"-",80)="-",HD="C & P Exam Integrity Report",DVBCDT=$$FMTE^XLFDT(DT,"5DZ")
U IO F DFN=0:0 S X="",DFN=$O(^DVB(396.3,"B",DFN)) Q:DFN="" F DA=0:0 S DA=$O(^DVB(396.3,"B",DFN,DA)) Q:DA="" D CHECK
I '$D(^TMP($J)) D HDR W !!!!!?25,"Nothing found to report",!!
I $D(^TMP($J)) D PRINT
I ('$D(^TMP("DVBA",$J))&((+STYLEIND'="4")&(+$$RPTCHK=1))) DO
.D NOW^%DTC S Y=X X ^DD("DD")
.S TODAYDT=Y K Y,X
.S SITE=$$SITE^DVBCUTL4
.D RPTHD^DVBCULAP W !!!!!?25,"Nothing found to report",!!
.I (IOST?1"C-".E) D PAUSE^DVBCUTL4
.K TODAYDT,SITE
I $D(^TMP("DVBA",$J)) D:(+$$RPTCHK=1) ^DVBCULAP
;
EXIT D ^%ZISC
S FF=IOF W:'$D(ZTQUEUED) @FF,!!!
I $D(ZTQUEUED)&($D(DVBCMAN)) D KILL^%ZTLOAD
K %,%Y,DTA,DTB,DTOUT,DVBCDT,FF,HD,NAME,PG,I,ZTSAVE,POP,X,XI,Y
K ZTQUEUED,ZTDESC,ZTIO,ZTRTN,ZTSK,ITEMS,PRINT,DFN,DA,LN,DVBCMAN,DVBCQUIT,GETOUT,DVBCX,HDRPRT
K ^TMP("DVBA",$J),^TMP($J),REQDA,STYLEIND,DVBAY,DIQ,DIR,DIRUT,DUOUT
K DR,DIC
Q
;
HDR S PG=PG+1,HDRPRT="" W @IOF
W !,DVBCDT,?(80-$L(HD)\2),HD,?69,"Page: ",PG,!,?(80-$L($$SITE^DVBCUTL4)\2),$$SITE^DVBCUTL4,!!,"Veteran name",?28,"Social Sec #",?50,"Missing items",!
Q
;
LINKCK ;** Patient DFN's w/ 2507's >3 days w/out links
;** Called - 2507 C&P INTEG RPT'=OFF
;** $D(DVBAFND) - 2507 >3 days old w/out links
N DVBAX,DVBADAYS
S:'$D(X) X=""
S DVBAX=X ;**Save X (prob report var)
I +$$STYLE^DVBCUTL8(REQDA)=1 DO
.K X,X1,X2
.D NOW^%DTC
.S X2=($P(^DVB(396.3,REQDA,0),U,5)\1),X1=X\1
.K X D ^%DTC
.S DVBADAYS=X K X
.S X=DVBAX ;**Reset X (prob var)
.I +DVBADAYS>3 DO ;**2507 >3 days old, check links
..N APPTDA S APPTDA=""
..K DVBAFND
..I +$O(^DVB(396.95,"AR",REQDA,APPTDA))'>0 DO
...S:$$TRANCHK^DVBCUTA4(REQDA)=0 DVBAFND="" ;**2507 w/out links
..I $D(DVBAFND) DO ;**Unlinked 2507 >3 days old
...S:(+$$RPTCHK=1) ^TMP("DVBA",$J,NAME,DFN)="" ;**TMP("DVBA") - unlinked 2507's
...S X=X_"199^"
K DVBAFND
Q
;
RPTCHK() ;**Check C&P Report Param field - 396.1
N PARAMDA,PARAMVAL S PARAMDA=0
S PARAMDA=$O(^DVB(396.1,PARAMDA))
S PARAMVAL=$P(^DVB(396.1,PARAMDA,0),U,19)
Q PARAMVAL
;
NAMELN W LN,!!,NAME,?28,$P(^DPT(DFN,0),U,9)
Q
;
SETSTYLE ;
S PARAMDA=0
S PARAMDA=$O(^DVB(396.1,PARAMDA))
S STYLEIND=$P(^DVB(396.1,PARAMDA,0),U,15)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCCHKR 5172 printed Sep 23, 2025@19:19:46 Page 2
DVBCCHKR ;ALB/GTS-557/THM-CHECK C&P REQUEST FOR CRITICAL DATA ; 3/20/19 7:56am
+1 ;;2.7;AMIE;**17,194,193,209**;Apr 10, 1995;Build 17
+2 ;
+3 ;** Version Changes
+4 ; 2.7 - GTS/C&P appt links report (Enhc 13)
+5 ;
+6 SET DVBCMAN=""
GOTO EN
+7 ;
CHECK NEW OLDX
+1 SET OLDX=X
SET DTA=^DVB(396.3,DA,0)
SET DTB=$SELECT($DATA(^DVB(396.3,DA,1)):^(1),1:"")
+2 ;RRA DVBA*194 priority of exam no longer populated so remove from validation list
+3 ;AJF;Request Status conversion
+4 ;Patch 209, reverting report screeing back to before 193
+5 if ($PIECE(DTA,U,18)=6)!($PIECE(DTA,U,18)=7)
QUIT
FOR XI=2,3,4,18
IF $PIECE(^DVB(396.3,DA,0),U,XI)=""
SET X=X_XI_U
+6 IF $PIECE(DTB,U,4)=""
SET X=X_99_U
+7 ;no exams selected
IF $ORDER(^DVB(396.4,"C",DA,0))=""
SET X=X_98_U
+8 SET REQDA=DA
SET NAME=$PIECE(^DPT(DFN,0),U,1)
if STYLEIND'="4"
DO LINKCK
+9 IF OLDX'=X
Begin DoDot:1
+10 if $EXTRACT(X,$LENGTH(X))="^"
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+11 SET X=X_";"_DA_"~"
End DoDot:1
+12 IF X]""
SET ^TMP($JOB,NAME,DFN)=X
+13 QUIT
+14 ;
PRINT DO HDR
SET NAME=""
+1 FOR XI=0:0
SET NAME=$ORDER(^TMP($JOB,NAME))
if NAME=""!($DATA(DVBCQUIT))
QUIT
Begin DoDot:1
+2 SET (DVBAPC,DVBADTA)=""
+3 FOR DFN=0:0
SET DFN=$ORDER(^TMP($JOB,NAME,DFN))
if DFN=""!($DATA(DVBCQUIT))
QUIT
Begin DoDot:2
+4 IF (IOST?1"C-".E)
IF ($Y>(IOSL-9))
DO TERM^DVBCUTL3
if $DATA(GETOUT)
SET DVBCQUIT=""
+5 IF '$DATA(DVBCQUIT)
Begin DoDot:3
+6 if ($Y>(IOSL-9))
DO HDR
+7 ;**Output name
DO NAMELN
+8 FOR DVBAPC=1:1
SET DVBADTA=$PIECE(^TMP($JOB,NAME,DFN),"~",DVBAPC)
if DVBADTA=""
QUIT
Begin DoDot:4
+9 WRITE !
+10 ;**DVBADTA=Prob pce
SET DTA=$PIECE(DVBADTA,";",1)
SET REQDA=$PIECE(DVBADTA,";",2)
+11 FOR DVBCX=1:1
SET DVBAY=$PIECE(DTA,U,DVBCX)
if DVBAY=""!($DATA(DVBCQUIT))
QUIT
IF DVBAY]""
DO PRINT1
End DoDot:4
End DoDot:3
End DoDot:2
+12 KILL DVBAPC,DVBADTA
End DoDot:1
+13 IF '$DATA(DVBCQUIT)&(IOST?1"C-".E)
DO TERM^DVBCUTL3
if $DATA(GETOUT)
SET DVBCQUIT=""
+14 QUIT
+15 ;
PRINT1 IF (IOST?1"C-".E)
IF ($Y>(IOSL-2))
DO TERM^DVBCUTL3
if $DATA(GETOUT)
SET DVBCQUIT=""
+1 IF '$DATA(DVBCQUIT)
Begin DoDot:1
+2 IF ($Y>(IOSL-2))
DO HDR
DO NAMELN
+3 WRITE ?50,$SELECT(DVBAY=2:"Request date",DVBAY=3:"Regional office number",DVBAY=4:"Requester",DVBAY=10:"Priority of exam",DVBAY=18:"Request status",DVBAY=99:"Routing location",1:"")
+4 if DVBAY=98
WRITE ?50,"** No exams selected **"
+5 if DVBAY=199
WRITE ?50,"** No C&P Appt's linked **"
+6 WRITE !
End DoDot:1
+7 QUIT
+8 ;
EN DO HOME^%ZIS
SET FF=IOF
+1 WRITE @FF,!!,"This report will check the 2507 REQUEST file for missing crucial data.",!!,"All requests will be checked and those found missing any of the following",!,"will be reported:",!!
+2 WRITE "1) Request date",!,"2) Regional office number",!,"3) Requester",!
+3 WRITE "4) Request status",!,"5) Routing location",!,"6) No exams selected"
+4 DO SETSTYLE
+5 if STYLEIND=4
WRITE !
+6 if STYLEIND'="4"
WRITE !,"7) Requests older than 3 days without C&P Appt links ",!
+7 WRITE !
KILL PARAMDA
+8 ;
ASK WRITE "Do you want to continue"
SET %=2
DO YN^DICN
if $DATA(DTOUT)
GOTO EXIT
+1 IF $DATA(%Y)
IF %Y["?"
WRITE !!,"Enter Y to print the report or N to quit.",!!
HANG 2
GOTO ASK
+2 IF $DATA(%)
IF %'=1
GOTO EXIT
+3 ;
DEV WRITE !!
SET %ZIS="AEQ"
DO ^%ZIS
KILL %ZIS
if POP
GOTO EXIT
IF $DATA(IO("Q"))
SET ZTIO=ION
SET ZTDESC="2507 exam integrity report"
SET ZTRTN="GO^DVBCCHKR"
FOR I="FF"
SET ZTSAVE(I)=""
+1 IF $TEST
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !!,"Request queued",!!
GOTO EXIT
+2 ;
GO if '$DATA(STYLEIND)
DO SETSTYLE
+1 KILL ^TMP($JOB),LN,DVBCQUIT,GETOUT
SET (ITEMS,PG)=0
SET $PIECE(LN,"-",80)="-"
SET HD="C & P Exam Integrity Report"
SET DVBCDT=$$FMTE^XLFDT(DT,"5DZ")
+2 USE IO
FOR DFN=0:0
SET X=""
SET DFN=$ORDER(^DVB(396.3,"B",DFN))
if DFN=""
QUIT
FOR DA=0:0
SET DA=$ORDER(^DVB(396.3,"B",DFN,DA))
if DA=""
QUIT
DO CHECK
+3 IF '$DATA(^TMP($JOB))
DO HDR
WRITE !!!!!?25,"Nothing found to report",!!
+4 IF $DATA(^TMP($JOB))
DO PRINT
+5 IF ('$DATA(^TMP("DVBA",$JOB))&((+STYLEIND'="4")&(+$$RPTCHK=1)))
Begin DoDot:1
+6 DO NOW^%DTC
SET Y=X
XECUTE ^DD("DD")
+7 SET TODAYDT=Y
KILL Y,X
+8 SET SITE=$$SITE^DVBCUTL4
+9 DO RPTHD^DVBCULAP
WRITE !!!!!?25,"Nothing found to report",!!
+10 IF (IOST?1"C-".E)
DO PAUSE^DVBCUTL4
+11 KILL TODAYDT,SITE
End DoDot:1
+12 IF $DATA(^TMP("DVBA",$JOB))
if (+$$RPTCHK=1)
DO ^DVBCULAP
+13 ;
EXIT DO ^%ZISC
+1 SET FF=IOF
if '$DATA(ZTQUEUED)
WRITE @FF,!!!
+2 IF $DATA(ZTQUEUED)&($DATA(DVBCMAN))
DO KILL^%ZTLOAD
+3 KILL %,%Y,DTA,DTB,DTOUT,DVBCDT,FF,HD,NAME,PG,I,ZTSAVE,POP,X,XI,Y
+4 KILL ZTQUEUED,ZTDESC,ZTIO,ZTRTN,ZTSK,ITEMS,PRINT,DFN,DA,LN,DVBCMAN,DVBCQUIT,GETOUT,DVBCX,HDRPRT
+5 KILL ^TMP("DVBA",$JOB),^TMP($JOB),REQDA,STYLEIND,DVBAY,DIQ,DIR,DIRUT,DUOUT
+6 KILL DR,DIC
+7 QUIT
+8 ;
HDR SET PG=PG+1
SET HDRPRT=""
WRITE @IOF
+1 WRITE !,DVBCDT,?(80-$LENGTH(HD)\2),HD,?69,"Page: ",PG,!,?(80-$LENGTH($$SITE^DVBCUTL4)\2),$$SITE^DVBCUTL4,!!,"Veteran name",?28,"Social Sec #",?50,"Missing items",!
+2 QUIT
+3 ;
LINKCK ;** Patient DFN's w/ 2507's >3 days w/out links
+1 ;** Called - 2507 C&P INTEG RPT'=OFF
+2 ;** $D(DVBAFND) - 2507 >3 days old w/out links
+3 NEW DVBAX,DVBADAYS
+4 if '$DATA(X)
SET X=""
+5 ;**Save X (prob report var)
SET DVBAX=X
+6 IF +$$STYLE^DVBCUTL8(REQDA)=1
Begin DoDot:1
+7 KILL X,X1,X2
+8 DO NOW^%DTC
+9 SET X2=($PIECE(^DVB(396.3,REQDA,0),U,5)\1)
SET X1=X\1
+10 KILL X
DO ^%DTC
+11 SET DVBADAYS=X
KILL X
+12 ;**Reset X (prob var)
SET X=DVBAX
+13 ;**2507 >3 days old, check links
IF +DVBADAYS>3
Begin DoDot:2
+14 NEW APPTDA
SET APPTDA=""
+15 KILL DVBAFND
+16 IF +$ORDER(^DVB(396.95,"AR",REQDA,APPTDA))'>0
Begin DoDot:3
+17 ;**2507 w/out links
if $$TRANCHK^DVBCUTA4(REQDA)=0
SET DVBAFND=""
End DoDot:3
+18 ;**Unlinked 2507 >3 days old
IF $DATA(DVBAFND)
Begin DoDot:3
+19 ;**TMP("DVBA") - unlinked 2507's
if (+$$RPTCHK=1)
SET ^TMP("DVBA",$JOB,NAME,DFN)=""
+20 SET X=X_"199^"
End DoDot:3
End DoDot:2
End DoDot:1
+21 KILL DVBAFND
+22 QUIT
+23 ;
RPTCHK() ;**Check C&P Report Param field - 396.1
+1 NEW PARAMDA,PARAMVAL
SET PARAMDA=0
+2 SET PARAMDA=$ORDER(^DVB(396.1,PARAMDA))
+3 SET PARAMVAL=$PIECE(^DVB(396.1,PARAMDA,0),U,19)
+4 QUIT PARAMVAL
+5 ;
NAMELN WRITE LN,!!,NAME,?28,$PIECE(^DPT(DFN,0),U,9)
+1 QUIT
+2 ;
SETSTYLE ;
+1 SET PARAMDA=0
+2 SET PARAMDA=$ORDER(^DVB(396.1,PARAMDA))
+3 SET STYLEIND=$PIECE(^DVB(396.1,PARAMDA,0),U,15)
+4 QUIT
