Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DVBCIRP1

DVBCIRP1.m

Go to the documentation of this file.
  1. DVBCIRP1 ;ALB/GTS-AMIE INSUFFICIENT 2507 RPT -CONT 1 ; 11/10/94 1:30 PM
  1. ;;2.7;AMIE;**13,19,27,149,184,185**;Apr 10, 1995;Build 18
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. ;** Version Changes
  1. ; 2.7 - New routine (Enhc 15)
  1. ;
  1. SUMRPT ;**Output the summary report
  1. W:IOST?1"C-".E @IOF
  1. D SUMHD
  1. ;print request data
  1. W !?3,"Total 2507 requests received for date range:",?71,$J(DVBARQCT,5)
  1. W !?3,"Total insufficient 2507 requests received for date range:",?71,$J(DVBAINRQ,5)
  1. W !?3,"Total insufficient 2507 requests cancelled by RO for date range:",?71,$J(DVBACAN("REQ"),5)
  1. I DVBARQCT>0 D
  1. .S PERCENT=(DVBAINRQ/DVBARQCT)*100
  1. .W !?3,"% of insufficient requests per total requests received:",?71,$J(PERCENT,5,1)_"%"
  1. .S PERCENT=((DVBAINRQ-DVBACAN("REQ"))/DVBARQCT)*100
  1. .W !?3,"% of uncancelled insufficient requests per total requests received:",?71,$J(PERCENT,5,1)_"%"
  1. I DVBARQCT'>0 D
  1. .S PERCENT=0
  1. .W !?3,"% of insufficient requests per total requests received:",?71,$J(PERCENT,5,1)_"%"
  1. .W !?3,"% of uncancelled insufficient requests per total requests received:",?71,$J(PERCENT,5,1)_"%"
  1. ;print exam data
  1. W !!?3,"Total 2507 exams received for date range:",?71,$J(DVBAXMCT,5)
  1. W !?3,"Total insufficient 2507 exams received for date range:",?71,$J(DVBAINXM,5)
  1. W !?3,"Total insufficient 2507 exams cancelled by RO for date range:",?71,$J(DVBACAN("EXM"),5)
  1. I DVBAXMCT>0 D
  1. .S PERCENT=(DVBAINXM/DVBAXMCT)*100
  1. .W !?3,"% of insufficient exams per total exams received:",?71,$J(PERCENT,5,1)_"%"
  1. .S PERCENT=((DVBAINXM-DVBACAN("EXM"))/DVBAXMCT)*100
  1. .W !?3,"% of uncancelled insufficient exams per total exams received:",?71,$J(PERCENT,5,1)_"%"
  1. I DVBAXMCT'>0 D
  1. .S PERCENT=0
  1. .W !?3,"% of insufficient exams per total exams received:",?71,$J(PERCENT,5,1)_"%"
  1. .W !?3,"% of uncancelled insufficient exams per total exams received:",?71,$J(PERCENT,5,1)_"%"
  1. ;print insufficient reason data
  1. I IOST?1"C-".E DO
  1. .K DTOUT,DUOUT
  1. .W !!
  1. .D PAUSE^DVBCUTL4
  1. .I '$D(DTOUT),('$D(DUOUT)) DO
  1. ..W @IOF
  1. ..D SUMHD
  1. I '$D(DTOUT),('$D(DUOUT)) DO
  1. .W:IOST'?1"C-".E !!
  1. .W !?15,"Summary of insufficient exams per Reason",!
  1. .W !?3,"Reason",?53,"Num",?59,"Percent"
  1. .N DVBARSLP S DVBARSLP=""
  1. .F S DVBARSLP=$O(DVBAINXM(DVBARSLP)) Q:DVBARSLP="" DO ;**Reason tot's
  1. ..W:+DVBARSLP>0 !?3,$P(^DVB(396.94,DVBARSLP,0),U,3),?53,DVBAINXM(DVBARSLP)
  1. ..I +DVBARSLP'>0,(+DVBAINXM(DVBARSLP)>0) W !?3,"Exams without insufficient reason indicated",?53,DVBAINXM(DVBARSLP)
  1. ..W:(+DVBAINXM(DVBARSLP)>0&(DVBAINXM>0)) ?59,($P(((DVBAINXM(DVBARSLP)/DVBAINXM)*100),".",1))_$S($E($P(((DVBAINXM(DVBARSLP)/DVBAINXM)*100),".",2),1,1)'="":"."_$E($P(((DVBAINXM(DVBARSLP)/DVBAINXM)*100),".",2),1,1),1:"")_" %"
  1. .I IOST?1"C-".E DO
  1. ..D CONTMES^DVBCUTL4
  1. Q
  1. ;
  1. SUMHD ;** Output Summary Report heading
  1. N STRTDT,LSTDT,DVBATXT,DVBASL
  1. W !?15,"Summary Insufficient Exam Report for ",$$SITE^DVBCUTL4(),!
  1. S Y=$P(BEGDT,".",1) X ^DD("DD") S STRTDT=Y K Y
  1. S Y=$P(ENDDT,".",1) X ^DD("DD") S LSTDT=Y K Y
  1. S DVBASL=$L($$SITE^DVBCUTL4)
  1. S DVBATXT=$$PRHD^DVBCIUTL(DVBAPRTY)
  1. W ?(((67+DVBASL)-$L(DVBATXT))\2),DVBATXT,!
  1. W !?16,"For Date Range: "_STRTDT_" to "_LSTDT,!
  1. Q
  1. ;
  1. DETAIL ;** Output reason, exam type and exam info
  1. N STRTDT,LSTDT,DVBARQST,DVBAEXMP,DVBAP,DVBAPREXM,MSGCNT
  1. S MSGCNT=0
  1. K ^TMP("DVBAEXAMS",$J),^TMP("INSUFF",$J)
  1. S X=$P(BEGDT,".",1),STRTDT=$$FMTE^XLFDT(X,"5DZ")
  1. S Y=$P(ENDDT,".",1),LSTDT=$$FMTE^XLFDT(Y,"5DZ")
  1. U IO
  1. S DVBADTLP=BEGDT
  1. S DVBAENDL=ENDDT
  1. S DVBAPRTY=$S(($G(DVBAPRTY)["BDD"):";BDD;QS;",($G(DVBAPRTY)["IDES"):";IDES;",($G(DVBAPRTY)["AO"):";AO;",1:"")
  1. D:((DVBAPRTY']"")!(DVBAPRTY["AO")!(DVBAPRTY["IDES")) DETHD^DVBCIUTL
  1. S RSDA=""
  1. S DVBAPG1=""
  1. F S RSDA=$O(DVBAARY("REASON",RSDA)) Q:(RSDA=""!($D(GETOUT))) DO
  1. .K DVBARSPT
  1. .S TPDA=""
  1. .F S TPDA=$O(^TMP($J,"XMTYPE",TPDA)) Q:(TPDA=""!($D(GETOUT))) DO
  1. ..K DVBAXMPT
  1. ..S XMDA=""
  1. ..F S XMDA=$O(^DVB(396.4,"AIT",RSDA,TPDA,XMDA)) Q:(XMDA=""!($D(GETOUT))) DO
  1. ...S DVBARQST=$G(^DVB(396.3,$P(^DVB(396.4,XMDA,0),U,2),0))
  1. ...;retrieve Priority of Exam from Current/Parent(if exists) 2507 Request
  1. ...S DVBAPREXM=$$CHKREQ($P(^DVB(396.4,XMDA,0),U,2))
  1. ...I $P(DVBARQST,U,5)>DVBADTLP,($P(DVBARQST,U,5)<DVBAENDL) D
  1. ....;Current-As Is (All Others, except new priorities)
  1. ....D:((DVBAPRTY']"")&((";BDD;QS;IDES;AO;")'[(";"_DVBAPREXM_";"))) EXMOUT^DVBCIUTL
  1. ....;Report for Specific Priority of Exam(s)
  1. ....D:((DVBAPRTY]"")&(DVBAPRTY[(";"_DVBAPREXM_";")))
  1. .....D:(DVBAPREXM="AO")!(DVBAPREXM="IDES") EXMOUT^DVBCIUTL ;Agent Orange or IDES Single Report
  1. .....;BDD,QS require report for each priority code
  1. .....;for performance grab all data then print 2 reports
  1. .....S:(DVBAPREXM'="AO")&(DVBAPREXM'="IDES") ^TMP("DVBAEXAMS",$J,DVBAPREXM,RSDA,TPDA,XMDA)=""
  1. I '$D(GETOUT),(IOST?1"C-".E),((DVBAPRTY']"")!(DVBAPRTY["AO")) D CONTMES^DVBCUTL4
  1. D:((DVBAPRTY]"")&(DVBAPRTY'["AO")&(DVBAPRTY'["IDES")) ;print BDD reports
  1. .K DVBAPG1 S DVBAEXMP=DVBAPRTY,RSDA=""
  1. .F DVBAP=$P(DVBAEXMP,";",2),$P(DVBAEXMP,";",3) D
  1. ..Q:DVBAP=""
  1. ..S DVBAPRTY=DVBAP
  1. ..D DETHD^DVBCIUTL S DVBAPG1=""
  1. ..F S RSDA=$O(^TMP("DVBAEXAMS",$J,DVBAP,RSDA)) Q:(('+RSDA)!($D(GETOUT))) D
  1. ...K DVBARSPT S TPDA=""
  1. ...F S TPDA=$O(^TMP("DVBAEXAMS",$J,DVBAP,RSDA,TPDA)) Q:(('+TPDA)!($D(GETOUT))) D
  1. ....K DVBAXMPT S XMDA=""
  1. ....F S XMDA=$O(^TMP("DVBAEXAMS",$J,DVBAP,RSDA,TPDA,XMDA)) Q:(('+XMDA)!($D(GETOUT))) D EXMOUT^DVBCIUTL
  1. ..I '$D(GETOUT),(IOST?1"C-".E) D CONTMES^DVBCUTL4
  1. ..K GETOUT W !
  1. D ^%ZISC
  1. D KVARS ;**KILL the variables used by DETAIL
  1. Q
  1. ;
  1. KVARS ;** Final Kill for Detail report
  1. S:$D(ZTQUEUED) ZTREQ="@"
  1. K ^TMP($J),DVBAARY,DVBANAME,DVBASSN,DVBACNUM,RSDA,TPDA,XMDA,DVBADTLP,DVBAENDL
  1. K DVBARSPT,DVBAXMPT,REQDA,DFN,DVBAORXM,DVBAXMTP,DVBACMND,DVBAORPV,DVBAORP1
  1. K DVBADTWK,DVBADTE,DVBAORDT,DVBANAM1,GETOUT,DVBAARY,DVBAPG1,DVBARQDT,DVBAXDT
  1. K DVBAXRS,MSGCNT,^TMP("DVBAEXAMS",$J)
  1. Q
  1. ;
  1. DETSEL ;** Select the details to report
  1. D RSEL^DVBCIUTL
  1. I '$D(DVBAARY("REASON")) S DVBAQTSL=""
  1. I $D(DVBAQTSL) DO
  1. .S DIR("A",1)="You have not selected Insufficient reasons to report."
  1. .S DIR("A",2)="This is required to print the Detailed report."
  1. .S DIR("A",3)=" "
  1. .S DIR(0)="FAO^1:1",DIR("A")="Hit Return to continue." D ^DIR K DIR,X,Y
  1. I '$D(DVBAQTSL) DO
  1. .D XMSEL^DVBCIUTL
  1. .I '$D(^TMP($J,"XMTYPE")) S DVBAQTSL=""
  1. .I $D(DVBAQTSL) DO
  1. ..S DIR("A",1)="You have not selected Exams to report."
  1. ..S DIR("A",2)="This is required to print the Detailed report."
  1. ..S DIR("A",3)=" "
  1. ..S DIR(0)="FAO^1:1",DIR("A")="Hit Return to continue." D ^DIR K DIR,X,Y
  1. ..K DVBAARY("REASON")
  1. Q
  1. ;
  1. ;Input: IEN of 2507 Request in File #396.3
  1. ;Output: Priority of Exam for the Current/Parent 2507 Request
  1. CHKREQ(DVBARIEN) ;check for parent requests
  1. N DVBAPIEN,DVBAPEXM
  1. Q:($G(DVBARIEN)']"") ""
  1. S DVBAPEXM=$P($G(^DVB(396.3,DVBARIEN,0)),U,10) ;Priority of Exam
  1. S DVBAPIEN=$P($G(^DVB(396.3,DVBARIEN,5)),U) ;parent IEN if it exists
  1. I (DVBAPIEN]"") D ;Parent 2507 Request
  1. .S DVBAPEXM=$P($G(^DVB(396.3,DVBAPIEN,0)),U,10) ;Priority of Exam
  1. Q DVBAPEXM