source: FOIAVistA/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCCHKR.m@ 1470

Last change on this file since 1470 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 4.7 KB
Line 
1DVBCCHKR ;ALB/GTS-557/THM-CHECK C&P REQUEST FOR CRITICAL DATA ; 4/23/91 7:53 AM
2 ;;2.7;AMIE;**17**;Apr 10, 1995
3 ;
4 ;** Version Changes
5 ; 2.7 - GTS/C&P appt links report (Enhc 13)
6 ;
7 S DVBCMAN="" G EN
8 ;
9CHECK N OLDX
10 S OLDX=X,DTA=^DVB(396.3,DA,0),DTB=$S($D(^DVB(396.3,DA,1)):^(1),1:"")
11 Q:$P(DTA,U,18)["X" F XI=2,3,4,10,18 I $P(^DVB(396.3,DA,0),U,XI)="" S X=X_XI_U
12 I $P(DTB,U,4)="" S X=X_99_U
13 I $O(^DVB(396.4,"C",DA,0))="" S X=X_98_U ;no exams selected
14 S REQDA=DA,NAME=$P(^DPT(DFN,0),U,1) D:STYLEIND'="4" LINKCK
15 I OLDX'=X DO
16 .S:$E(X,$L(X))="^" X=$E(X,1,($L(X)-1))
17 .S X=X_";"_DA_"~"
18 I X]"" S ^TMP($J,NAME,DFN)=X
19 Q
20 ;
21PRINT D HDR S NAME=""
22 F XI=0:0 S NAME=$O(^TMP($J,NAME)) Q:NAME=""!($D(DVBCQUIT)) DO
23 .S (DVBAPC,DVBADTA)=""
24 .F DFN=0:0 S DFN=$O(^TMP($J,NAME,DFN)) Q:DFN=""!($D(DVBCQUIT)) DO
25 ..I (IOST?1"C-".E),($Y>(IOSL-9)) D TERM^DVBCUTL3 S:$D(GETOUT) DVBCQUIT=""
26 ..I '$D(DVBCQUIT) DO
27 ...D:($Y>(IOSL-9)) HDR
28 ...D NAMELN ;**Output name
29 ...F DVBAPC=1:1 S DVBADTA=$P(^TMP($J,NAME,DFN),"~",DVBAPC) Q:DVBADTA="" DO
30 ....W !
31 ....S DTA=$P(DVBADTA,";",1),REQDA=$P(DVBADTA,";",2) ;**DVBADTA=Prob pce
32 ....F DVBCX=1:1 S DVBAY=$P(DTA,U,DVBCX) Q:DVBAY=""!($D(DVBCQUIT)) I DVBAY]"" D PRINT1
33 .K DVBAPC,DVBADTA
34 I '$D(DVBCQUIT)&(IOST?1"C-".E) D TERM^DVBCUTL3 S:$D(GETOUT) DVBCQUIT=""
35 Q
36 ;
37PRINT1 I (IOST?1"C-".E),($Y>(IOSL-2)) D TERM^DVBCUTL3 S:$D(GETOUT) DVBCQUIT=""
38 I '$D(DVBCQUIT) DO
39 .I ($Y>(IOSL-2)) D HDR,NAMELN
40 .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:"")
41 .W:DVBAY=98 ?50,"** No exams selected **"
42 .W:DVBAY=199 ?50,"** No C&P Appt's linked **"
43 .W !
44 Q
45 ;
46EN D HOME^%ZIS S FF=IOF
47 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:",!!
48 W "1) Request date",!,"2) Regional office number",!,"3) Requester",!,"4) Priority of exam",!
49 W "5) Request status",!,"6) Routing location",!,"7) No exams selected"
50 D SETSTYLE
51 W:STYLEIND=4 !
52 W:STYLEIND'="4" !,"8) Requests older than 3 days without C&P Appt links ",!
53 W ! K PARAMDA
54 ;
55ASK W "Do you want to continue" S %=2 D YN^DICN G:$D(DTOUT) EXIT
56 I $D(%Y),%Y["?" W !!,"Enter Y to print the report or N to quit.",!! H 2 G ASK
57 I $D(%),%'=1 G EXIT
58 ;
59DEV 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)=""
60 I D ^%ZTLOAD W:$D(ZTSK) !!,"Request queued",!! G EXIT
61 ;
62GO D:'$D(STYLEIND) SETSTYLE
63 K ^TMP($J),LN,DVBCQUIT,GETOUT S (ITEMS,PG)=0,$P(LN,"-",80)="-",HD="C & P Exam Integrity Report",DVBCDT=$$FMTE^XLFDT(DT,"5DZ")
64 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
65 I '$D(^TMP($J)) D HDR W !!!!!?25,"Nothing found to report",!!
66 I $D(^TMP($J)) D PRINT
67 I ('$D(^TMP("DVBA",$J))&((+STYLEIND'="4")&(+$$RPTCHK=1))) DO
68 .D NOW^%DTC S Y=X X ^DD("DD")
69 .S TODAYDT=Y K Y,X
70 .S SITE=$$SITE^DVBCUTL4
71 .D RPTHD^DVBCULAP W !!!!!?25,"Nothing found to report",!!
72 .I (IOST?1"C-".E) D PAUSE^DVBCUTL4
73 .K TODAYDT,SITE
74 I $D(^TMP("DVBA",$J)) D:(+$$RPTCHK=1) ^DVBCULAP
75 ;
76EXIT D ^%ZISC
77 W:'$D(ZTQUEUED) @FF,!!!
78 I $D(ZTQUEUED)&($D(DVBCMAN)) D KILL^%ZTLOAD
79 K %,%Y,DTA,DTB,DTOUT,DVBCDT,FF,HD,NAME,PG,I,ZTSAVE,POP,X,XI,Y,ZTDESC,ZTIO,ZTRTN,ZTSK,ITEMS,PRINT,DFN,DA,LN,DVBCMAN,DVBCQUIT,GETOUT,DVBCX,HDRPRT
80 K ^TMP("DVBA",$J),^TMP($J),REQDA,STYLEIND,DVBAY,DIQ,DIR,DIRUT,DUOUT
81 K DR,DIC
82 Q
83 ;
84HDR S PG=PG+1,HDRPRT="" W @IOF
85 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",!
86 Q
87 ;
88LINKCK ;** Patient DFN's w/ 2507's >3 days w/out links
89 ;** Called - 2507 C&P INTEG RPT'=OFF
90 ;** $D(DVBAFND) - 2507 >3 days old w/out links
91 N DVBAX,DVBADAYS
92 S:'$D(X) X=""
93 S DVBAX=X ;**Save X (prob report var)
94 I +$$STYLE^DVBCUTL8(REQDA)=1 DO
95 .K X,X1,X2
96 .D NOW^%DTC
97 .S X2=($P(^DVB(396.3,REQDA,0),U,5)\1),X1=X\1
98 .K X D ^%DTC
99 .S DVBADAYS=X K X
100 .S X=DVBAX ;**Reset X (prob var)
101 .I +DVBADAYS>3 DO ;**2507 >3 days old, check links
102 ..N APPTDA S APPTDA=""
103 ..K DVBAFND
104 ..I +$O(^DVB(396.95,"AR",REQDA,APPTDA))'>0 DO
105 ...S:$$TRANCHK^DVBCUTA4(REQDA)=0 DVBAFND="" ;**2507 w/out links
106 ..I $D(DVBAFND) DO ;**Unlinked 2507 >3 days old
107 ...S:(+$$RPTCHK=1) ^TMP("DVBA",$J,NAME,DFN)="" ;**TMP("DVBA") - unlinked 2507's
108 ...S X=X_"199^"
109 K DVBAFND
110 Q
111 ;
112RPTCHK() ;**Check C&P Report Param field - 396.1
113 N PARAMDA,PARAMVAL S PARAMDA=0
114 S PARAMDA=$O(^DVB(396.1,PARAMDA))
115 S PARAMVAL=$P(^DVB(396.1,PARAMDA,0),U,19)
116 Q PARAMVAL
117 ;
118NAMELN W LN,!!,NAME,?28,$P(^DPT(DFN,0),U,9)
119 Q
120 ;
121SETSTYLE ;
122 S PARAMDA=0
123 S PARAMDA=$O(^DVB(396.1,PARAMDA))
124 S STYLEIND=$P(^DVB(396.1,PARAMDA,0),U,15)
125 Q
Note: See TracBrowser for help on using the repository browser.