DVBCULAP ;ALB/GTS-AMIE UNLINKED APPT REPORT ; 10/19/94 3:30 PM
;;2.7;AMIE;;Apr 10, 1995
;
;** Version Changes
; 2.7 - New routine (Enhc 13)
;
;** DVBCULAP run if 2507 Integrity Report Status parameter not OFF,
;** ^TMP("DVBA",$J) global is defined, C&P Report Parameter is ON
;
;** Variable Descriptions
;** ^TMP("DVBA",$J,NAME,DFN) must be defined for vets to be reported
;** prior to executing this routine. Global KILLed by calling rtn
;** ^TMP("DVBC",$J,NAME,DFN) will be equal to:
;** ^ exam date (ext) ^ date appt made ^ clerk ^ Appt Status (ext)
;
EN N TMPDA,STRTDT,PARAMDA,BEGDT,TODAYDT,SITE,LPCNT,SSN
N DVBAPNAM,DVBADFN
S SITE=$$SITE^DVBCUTL4
S (DVBAPNAM,DVBADFN)=""
S PARAMDA=0
S PARAMDA=$O(^DVB(396.1,PARAMDA))
D NOW^%DTC
S Y=X X ^DD("DD") S TODAYDT=Y K Y
;
;**Only appts for date previous to report date by number of days in
;** AMIE Site Parameter File - Days to Keep 2507 History
S X2=-(+$P(^DVB(396.1,PARAMDA,0),U,11)) S X1=X K X
D C^%DTC
S BEGDT=X-.0001,TMPDA=0 K X,X1,X2,STATUS,STATVAR
;
;** Create ^TMP("DVBC",$J) global entry for C&P appt in date range
F S DVBAPNAM=$O(^TMP("DVBA",$J,DVBAPNAM)) Q:DVBAPNAM="" DO
.F S DVBADFN=$O(^TMP("DVBA",$J,DVBAPNAM,DVBADFN)) Q:DVBADFN="" DO
..S STRTDT=BEGDT
..F S STRTDT=$O(^DPT(DVBADFN,"S",STRTDT)) Q:STRTDT="" DO
...I $P(^DPT(DVBADFN,"S",STRTDT,0),U,16)=1 DO ;**Appt is type C&P
....S TMPDA=TMPDA+1
....S DA=DVBADFN,DA(2.98)=STRTDT,DR="1900",DR(2.98)="19;20",DIC=2
....S DIQ="DVBAARY"
....K ^UTILITY("DIQ1",$J)
....D EN^DIQ1
....K ^UTILITY("DIQ1",$J)
....S Y=STRTDT X ^DD("DD")
....S OUTDT=Y
....S STATVAR=$$STATUS^SDAM1(DVBADFN,STRTDT,$P(^DPT(DVBADFN,"S",STRTDT,0),U,1),^DPT(DVBADFN,"S",STRTDT,0))
....S STATUS=$P(STATVAR,";",3)
....I DVBAARY(2.98,STRTDT,20)="" DO ;**If info in Hosp Loc file (#44)
.....K DA,DR,DIC,Y
.....S DIC="^SC("_$P(^DPT(DVBADFN,"S",STRTDT,0),U,1)_",""S"","_STRTDT_",1,"
.....S DIC(0)="MQ",X=DVBADFN
.....D ^DIC S SCIEN=+Y
.....K Y,DA,DR,DIC,DIQ,^UTILITY("DIQ1",$J)
.....S DA=$P(^DPT(DVBADFN,"S",STRTDT,0),U,1),DIC="^SC("
.....S DA(44.001)=STRTDT,DA(44.003)=SCIEN
.....S DR="1900",DR(44.001)="2",DR(44.003)="7;8"
.....S DIQ="DVBAARY"
.....D EN^DIQ1
.....K ^UTILITY("DIQ1",$J)
.....S ^TMP("DVBC",$J,DVBAPNAM,DVBADFN,TMPDA)=OUTDT_"^"_$S($D(DVBAARY(44.003,SCIEN,7)):DVBAARY(44.003,SCIEN,8)_"^"_DVBAARY(44.003,SCIEN,7)_"^"_STATUS,'$D(DVBAARY(44.003,SCIEN,7)):"BAD Hospital Location record - Contact IRM")
.....K SCIEN
....I DVBAARY(2.98,STRTDT,20)'="" DO ;**If info in DPT "S" node
.....S ^TMP("DVBC",$J,DVBAPNAM,DVBADFN,TMPDA)=OUTDT_"^"_DVBAARY(2.98,STRTDT,20)_"^"_DVBAARY(2.98,STRTDT,19)_"^"_STATUS
....K DVBAARY(2.98),Y,STATUS,STATVAR
..K DVBAARY(44.003)
I '$D(DVBCQUIT) D:$D(^TMP("DVBC",$J)) RPTHD
S (DVBADFN,DVBAPNAM,DVBANPGE)=""
K DVBCOUT
S:$D(DVBCQUIT) DVBCOUT=""
F S DVBAPNAM=$O(^TMP("DVBC",$J,DVBAPNAM)) Q:(DVBAPNAM=""!($D(DVBCOUT))) DO
.I $Y>(IOSL-13) DO
..I IOST?1"C-".E DO
...D PAUSE^DVBCUTL4
...S:+Y=0 DVBCOUT=""
..D:'$D(DVBCOUT) RPTHD
..S DVBANPGE=""
.I '$D(DVBCOUT) DO
..S DVBADFN=""
..F S DVBADFN=$O(^TMP("DVBC",$J,DVBAPNAM,DVBADFN)) Q:DVBADFN=""!($D(DVBCOUT)) DO
...I $Y>(IOSL-7) DO
....I IOST?1"C-".E DO
.....D PAUSE^DVBCUTL4
.....S:+Y=0 DVBCOUT=""
....D:'$D(DVBCOUT) RPTHD
....S DVBANPGE=""
...I '$D(DVBCOUT) DO
....S SSN=$P(^DPT(DVBADFN,0),U,9)
....K DVBCSSNO
....D SSNSHRT^DVBCUTIL
....D RPTSUBHD
....S TMPDA=""
....F S TMPDA=$O(^TMP("DVBC",$J,DVBAPNAM,DVBADFN,TMPDA)) Q:TMPDA=""!($D(DVBCOUT)) DO
.....I $Y>(IOSL-4) DO
......I IOST?1"C-".E DO
.......D PAUSE^DVBCUTL4
.......S:+Y=0 DVBCOUT=""
......S DVBANPGE=""
......D:'$D(DVBCOUT) RPTHD,RPTSUBHD
.....I '$D(DVBCOUT) DO
......W !,$P(^TMP("DVBC",$J,DVBAPNAM,DVBADFN,TMPDA),U,1)
......W ?25,$P(^TMP("DVBC",$J,DVBAPNAM,DVBADFN,TMPDA),U,2)
......W ?50,$P(^TMP("DVBC",$J,DVBAPNAM,DVBADFN,TMPDA),U,3)
I (IOST?1"C-".E),('$D(DVBCOUT)&($D(^TMP("DVBC",$J)))) D PAUSE^DVBCUTL4
KILL ^TMP("DVBC",$J),DVBCSSNO,DVBCOUT,OUTDT,DVBANPGE,DVBAARY(44.003)
Q
;
RPTHD ;
W @IOF
N DVBALN
W !,?(80-$L(SITE)\2),SITE
W !!,"AMIE appointment integrity report"
W !,"Date: ",TODAYDT
S $P(DVBALN,"-",80)=""
W !,DVBALN
Q
;
RPTSUBHD ;
W:'$D(DVBANPGE) !!
W !,"Veteran: ",DVBAPNAM,?50,"SSN: ",DVBCSSNO
W !!,"Appt Date",?25,"Date Appt Made",?50,"Clerk"
W !
K DVBANPGE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCULAP 4450 printed Oct 16, 2024@17:49:56 Page 2
DVBCULAP ;ALB/GTS-AMIE UNLINKED APPT REPORT ; 10/19/94 3:30 PM
+1 ;;2.7;AMIE;;Apr 10, 1995
+2 ;
+3 ;** Version Changes
+4 ; 2.7 - New routine (Enhc 13)
+5 ;
+6 ;** DVBCULAP run if 2507 Integrity Report Status parameter not OFF,
+7 ;** ^TMP("DVBA",$J) global is defined, C&P Report Parameter is ON
+8 ;
+9 ;** Variable Descriptions
+10 ;** ^TMP("DVBA",$J,NAME,DFN) must be defined for vets to be reported
+11 ;** prior to executing this routine. Global KILLed by calling rtn
+12 ;** ^TMP("DVBC",$J,NAME,DFN) will be equal to:
+13 ;** ^ exam date (ext) ^ date appt made ^ clerk ^ Appt Status (ext)
+14 ;
EN NEW TMPDA,STRTDT,PARAMDA,BEGDT,TODAYDT,SITE,LPCNT,SSN
+1 NEW DVBAPNAM,DVBADFN
+2 SET SITE=$$SITE^DVBCUTL4
+3 SET (DVBAPNAM,DVBADFN)=""
+4 SET PARAMDA=0
+5 SET PARAMDA=$ORDER(^DVB(396.1,PARAMDA))
+6 DO NOW^%DTC
+7 SET Y=X
XECUTE ^DD("DD")
SET TODAYDT=Y
KILL Y
+8 ;
+9 ;**Only appts for date previous to report date by number of days in
+10 ;** AMIE Site Parameter File - Days to Keep 2507 History
+11 SET X2=-(+$PIECE(^DVB(396.1,PARAMDA,0),U,11))
SET X1=X
KILL X
+12 DO C^%DTC
+13 SET BEGDT=X-.0001
SET TMPDA=0
KILL X,X1,X2,STATUS,STATVAR
+14 ;
+15 ;** Create ^TMP("DVBC",$J) global entry for C&P appt in date range
+16 FOR
SET DVBAPNAM=$ORDER(^TMP("DVBA",$JOB,DVBAPNAM))
if DVBAPNAM=""
QUIT
Begin DoDot:1
+17 FOR
SET DVBADFN=$ORDER(^TMP("DVBA",$JOB,DVBAPNAM,DVBADFN))
if DVBADFN=""
QUIT
Begin DoDot:2
+18 SET STRTDT=BEGDT
+19 FOR
SET STRTDT=$ORDER(^DPT(DVBADFN,"S",STRTDT))
if STRTDT=""
QUIT
Begin DoDot:3
+20 ;**Appt is type C&P
IF $PIECE(^DPT(DVBADFN,"S",STRTDT,0),U,16)=1
Begin DoDot:4
+21 SET TMPDA=TMPDA+1
+22 SET DA=DVBADFN
SET DA(2.98)=STRTDT
SET DR="1900"
SET DR(2.98)="19;20"
SET DIC=2
+23 SET DIQ="DVBAARY"
+24 KILL ^UTILITY("DIQ1",$JOB)
+25 DO EN^DIQ1
+26 KILL ^UTILITY("DIQ1",$JOB)
+27 SET Y=STRTDT
XECUTE ^DD("DD")
+28 SET OUTDT=Y
+29 SET STATVAR=$$STATUS^SDAM1(DVBADFN,STRTDT,$PIECE(^DPT(DVBADFN,"S",STRTDT,0),U,1),^DPT(DVBADFN,"S",STRTDT,0))
+30 SET STATUS=$PIECE(STATVAR,";",3)
+31 ;**If info in Hosp Loc file (#44)
IF DVBAARY(2.98,STRTDT,20)=""
Begin DoDot:5
+32 KILL DA,DR,DIC,Y
+33 SET DIC="^SC("_$PIECE(^DPT(DVBADFN,"S",STRTDT,0),U,1)_",""S"","_STRTDT_",1,"
+34 SET DIC(0)="MQ"
SET X=DVBADFN
+35 DO ^DIC
SET SCIEN=+Y
+36 KILL Y,DA,DR,DIC,DIQ,^UTILITY("DIQ1",$JOB)
+37 SET DA=$PIECE(^DPT(DVBADFN,"S",STRTDT,0),U,1)
SET DIC="^SC("
+38 SET DA(44.001)=STRTDT
SET DA(44.003)=SCIEN
+39 SET DR="1900"
SET DR(44.001)="2"
SET DR(44.003)="7;8"
+40 SET DIQ="DVBAARY"
+41 DO EN^DIQ1
+42 KILL ^UTILITY("DIQ1",$JOB)
+43 SET ^TMP("DVBC",$JOB,DVBAPNAM,DVBADFN,TMPDA)=OUTDT_"^"_$SELECT($DATA(DVBAARY(44.003,SCIEN,7)):DVBAARY(44.003,SCIEN,8)_"^"_DVBAARY(44.003,SCIEN,7)_"^"_STATUS,'$DATA(DVBAARY(44.003,SCIEN,7)):"BAD Hospital L
ocation record - Contact IRM")
+44 KILL SCIEN
End DoDot:5
+45 ;**If info in DPT "S" node
IF DVBAARY(2.98,STRTDT,20)'=""
Begin DoDot:5
+46 SET ^TMP("DVBC",$JOB,DVBAPNAM,DVBADFN,TMPDA)=OUTDT_"^"_DVBAARY(2.98,STRTDT,20)_"^"_DVBAARY(2.98,STRTDT,19)_"^"_STATUS
End DoDot:5
+47 KILL DVBAARY(2.98),Y,STATUS,STATVAR
End DoDot:4
End DoDot:3
+48 KILL DVBAARY(44.003)
End DoDot:2
End DoDot:1
+49 IF '$DATA(DVBCQUIT)
if $DATA(^TMP("DVBC",$JOB))
DO RPTHD
+50 SET (DVBADFN,DVBAPNAM,DVBANPGE)=""
+51 KILL DVBCOUT
+52 if $DATA(DVBCQUIT)
SET DVBCOUT=""
+53 FOR
SET DVBAPNAM=$ORDER(^TMP("DVBC",$JOB,DVBAPNAM))
if (DVBAPNAM=""!($DATA(DVBCOUT)))
QUIT
Begin DoDot:1
+54 IF $Y>(IOSL-13)
Begin DoDot:2
+55 IF IOST?1"C-".E
Begin DoDot:3
+56 DO PAUSE^DVBCUTL4
+57 if +Y=0
SET DVBCOUT=""
End DoDot:3
+58 if '$DATA(DVBCOUT)
DO RPTHD
+59 SET DVBANPGE=""
End DoDot:2
+60 IF '$DATA(DVBCOUT)
Begin DoDot:2
+61 SET DVBADFN=""
+62 FOR
SET DVBADFN=$ORDER(^TMP("DVBC",$JOB,DVBAPNAM,DVBADFN))
if DVBADFN=""!($DATA(DVBCOUT))
QUIT
Begin DoDot:3
+63 IF $Y>(IOSL-7)
Begin DoDot:4
+64 IF IOST?1"C-".E
Begin DoDot:5
+65 DO PAUSE^DVBCUTL4
+66 if +Y=0
SET DVBCOUT=""
End DoDot:5
+67 if '$DATA(DVBCOUT)
DO RPTHD
+68 SET DVBANPGE=""
End DoDot:4
+69 IF '$DATA(DVBCOUT)
Begin DoDot:4
+70 SET SSN=$PIECE(^DPT(DVBADFN,0),U,9)
+71 KILL DVBCSSNO
+72 DO SSNSHRT^DVBCUTIL
+73 DO RPTSUBHD
+74 SET TMPDA=""
+75 FOR
SET TMPDA=$ORDER(^TMP("DVBC",$JOB,DVBAPNAM,DVBADFN,TMPDA))
if TMPDA=""!($DATA(DVBCOUT))
QUIT
Begin DoDot:5
+76 IF $Y>(IOSL-4)
Begin DoDot:6
+77 IF IOST?1"C-".E
Begin DoDot:7
+78 DO PAUSE^DVBCUTL4
+79 if +Y=0
SET DVBCOUT=""
End DoDot:7
+80 SET DVBANPGE=""
+81 if '$DATA(DVBCOUT)
DO RPTHD
DO RPTSUBHD
End DoDot:6
+82 IF '$DATA(DVBCOUT)
Begin DoDot:6
+83 WRITE !,$PIECE(^TMP("DVBC",$JOB,DVBAPNAM,DVBADFN,TMPDA),U,1)
+84 WRITE ?25,$PIECE(^TMP("DVBC",$JOB,DVBAPNAM,DVBADFN,TMPDA),U,2)
+85 WRITE ?50,$PIECE(^TMP("DVBC",$JOB,DVBAPNAM,DVBADFN,TMPDA),U,3)
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+86 IF (IOST?1"C-".E)
IF ('$DATA(DVBCOUT)&($DATA(^TMP("DVBC",$JOB))))
DO PAUSE^DVBCUTL4
+87 KILL ^TMP("DVBC",$JOB),DVBCSSNO,DVBCOUT,OUTDT,DVBANPGE,DVBAARY(44.003)
+88 QUIT
+89 ;
RPTHD ;
+1 WRITE @IOF
+2 NEW DVBALN
+3 WRITE !,?(80-$LENGTH(SITE)\2),SITE
+4 WRITE !!,"AMIE appointment integrity report"
+5 WRITE !,"Date: ",TODAYDT
+6 SET $PIECE(DVBALN,"-",80)=""
+7 WRITE !,DVBALN
+8 QUIT
+9 ;
RPTSUBHD ;
+1 if '$DATA(DVBANPGE)
WRITE !!
+2 WRITE !,"Veteran: ",DVBAPNAM,?50,"SSN: ",DVBCSSNO
+3 WRITE !!,"Appt Date",?25,"Date Appt Made",?50,"Clerk"
+4 WRITE !
+5 KILL DVBANPGE
+6 QUIT
