source: FOIAVistA/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCAMI2.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 3.7 KB
Line 
1DVBCAMI2 ;ALB/GTS-557/THM-HOSPITAL AMIS 290 ; 7/1/91 9:48 AM
2 ;;2.7;AMIE;;Apr 10, 1995
3 ;
4 ;** NOTICE: This routine is part of an implementation of a Nationally
5 ;** Controlled Procedure. Local modifications to this routine
6 ;** are prohibited per VHA Directive 10-93-142
7 ;
8 ;** Version Changes
9 ; 2.7 - GTS/Coded to adjust 35 day clock calc (Enhc 13)
10 ;
11DAY30 K ^TMP("DVBC",$J)
12 F FA=DTRPT-.1:0 S FA=$O(^DPT(PNAM,"S",FA)) Q:FA=""!(FA>EDATE) I $D(^(FA,0)) S L=^(0),C=+L S YY=$P(L,U,2) I YY'="N"&(YY'="C")&(YY'="NA")&(YY'="CA")&(YY'="PC")&(YY'="PCA")&(YY'="NT") I FA'>EDATE S:$P(L,U,16)="1" ^TMP("DVBC",$J,9999999-FA,FA)=""
13 Q:'$D(^TMP("DVBC",$J)) S FB=$O(^TMP("DVBC",$J,0)),FA=$O(^TMP("DVBC",$J,FB,0)) I FA]"" S X1=FA,X2=$S(DTRPT]"":DTRPT,1:DVBCNOW) D ^%DTC I X>30 S TOT("30DAYEX")=TOT("30DAYEX")+1
14 Q
15 ;
16GO1 ; ** TFIND=1 If any exams have not been transferred. **
17 K TFIND F XI=0:0 S XI=$O(^DVB(396.4,"C",REQDA,XI)) Q:XI="" I $P(^DVB(396.4,XI,0),U,4)'="T" S TFIND=1
18 Q
19 ;if $D(TFIND) at least one exam to be done locally
20 ;
21PENDCNT I X'<0&(X'>90) S TOT("P90")=TOT("P90")+1
22 I X>90&(X'>120) S TOT("P121")=TOT("P121")+1
23 I X>120&(X'>150) S TOT("P151")=TOT("P151")+1
24 I X>150&(X'>180) S TOT("P181")=TOT("P181")+1
25 I X>180&(X'>365) S TOT("P365")=TOT("P365")+1
26 I X>365 S TOT("P366")=TOT("P366")+1
27 Q
28 ;
29SET S DTA=^DVB(396.3,REQDA,0),DFN=$P(DTA,U,1),DTREQ=$P(DTA,U,2),DTRPT=$P(DTA,U,5),DTSCHEDC=$P(DTA,U,6),DTRQCMP=$P(DTA,U,7),PRIO=$P(DTA,U,10),DTTRANS=$P(DTA,U,12),OWNDOM=$P(DTA,U,22)
30 S DTREL=$P(DTA,U,14),RQSTAT=$P(DTA,U,18),DTCAN=$P(DTA,U,19) K DTA
31 S DTA=$S($D(^DVB(396.3,REQDA,4)):^(4),1:""),TROUT=$P(DTA,U,1),DTTROUT=$P(DTA,U,3),DTTRIN=$P(DTA,U,4),DTTRET=$P(DTA,U,5)
32 I DTCAN]"",DTCAN<DTRPT,DTRPT]"" S DTRPT=DTCAN ;cancelled last day of month
33 Q:DTRPT="" ;never reported to MAS
34 I DTTRIN'<BDATE,DTTRIN'>EDATE S TOT("TRANSIN")=TOT("TRANSIN")+1 ;transfers in
35 I RQSTAT="CT",DTREL'<BDATE,DTREL'>EDATE S TOT("TRNRETTO")=TOT("TRNRETTO")+1 ;transfers returned to owners
36 I "^N^NT^P^S^T^"[RQSTAT,OWNDOM]"" S TOT("TRNPNDTO")=TOT("TRNPNDTO")+1 ;transfers pending return to others
37 Q:DTTRIN]"" ;** A transfer in (not counted further)
38 I DTREL'<BDATE,DTREL'>EDATE D DAY30
39 I DTTROUT'<BDATE,DTTROUT'>EDATE,TROUT="y" S TOT("TRANSOUT")=TOT("TRANSOUT")+1 ;transfers to other sites, not returns
40 I TROUT="",DTTRET'<BDATE,DTTRET'>EDATE S TOT("TRNRETFR")=TOT("TRNRETFR")+1 ;transfers returned from other sites
41 I TROUT="y",RQSTAT="P" S TOT("TRNPNDFR")=TOT("TRNPNDFR")+1 ;transfers pending return from other sites
42 I DTRPT'<BDATE,DTRPT'>EDATE,PRIO'="E" S TOT("RECEIVED")=TOT("RECEIVED")+1
43 I DTRPT'<BDATE,DTRPT'>EDATE,PRIO="E" S TOT("INSUFF")=TOT("INSUFF")+1
44 I DTRPT'<BDATE,DTRPT'>EDATE,RQSTAT'["X" D GO1 I $D(TFIND) S X1=$S(DTSCHEDC]"":DTSCHEDC,1:DVBCNOW),X2=DTRPT D ^%DTC I X>3 S TOT("3DAYSCH")=TOT("3DAYSCH")+1
45 I DTREL'<BDATE&(DTREL'>EDATE),RQSTAT="C"!(RQSTAT="R") S:PRIO'="E" DVBCPCTM=$$PROCDAY^DVBCUTL2(REQDA) S:PRIO="E" DVBCPCTM=$$INSFTME^DVBCUTA1(REQDA) S TOT("DAYS")=TOT("DAYS")+DVBCPCTM K DVBCPCTM
46 I DTRPT'>EDATE,"^N^NT^P^S^T^"[RQSTAT S X1=EDATE,X2=DTRPT D ^%DTC,PENDCNT
47 I DTRPT'>EDATE,"^C^CT^R^RX^X^"[RQSTAT,(+DTREL>EDATE)!(+DTCAN>EDATE) S X1=EDATE,X2=DTRPT D ^%DTC,PENDCNT
48 I DTREL'<BDATE&(DTREL'>EDATE),RQSTAT="C"!(RQSTAT="R") S TOT("COMPLETED")=TOT("COMPLETED")+1
49 I DTCAN'<BDATE,DTCAN'>EDATE,RQSTAT["X" S TOT("INCOMPLETE")=TOT("INCOMPLETE")+1
50 K DTRPT Q
51 ;
52GO U IO K ^TMP($J) S PG=0,%DT="TS",X="NOW" D ^%DT S DVBCNOW=Y
53 S PNAM="" F JJ=0:0 S PNAM=$O(^DVB(396.3,"B",PNAM)) Q:PNAM="" F REQDA=0:0 S REQDA=$O(^DVB(396.3,"B",PNAM,REQDA)) Q:REQDA="" D SET
54 S TOT("AVGDAYS")=0
55 I TOT("COMPLETED")>0 S TOT("AVGDAYS")=TOT("DAYS")/TOT("COMPLETED"),TOT("AVGDAYS")=$J(TOT("AVGDAYS"),5,1)
56 S TOT("PENDADJ")=PREVMO+TOT("RECEIVED")+TOT("INSUFF")-TOT("COMPLETED")-TOT("INCOMPLETE")
57 D BULLTXT^DVBCAMI1 G ^DVBCAMI3
Note: See TracBrowser for help on using the repository browser.