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

APCM14E.m

Go to the documentation of this file. 
  1. APCM14E ; IHS/CMI/LAB - IHS MU ;
  1.  ;;1.0;IHS MU PERFORMANCE REPORTS;**5,6**;MAR 26, 2012;Build 65
  1.  ;
  1.  ;
  1.  W:$D(IOF) @IOF
  1.  D XIT
  1. INTRO ;
  1.  S APCMRPTT=1  ;CONTROL VARIABLE FOR EP REPORT
  1.  S APCMRPTC=$O(^APCMMUCN("B","INTERIM STAGE 1 2014",0))
  1.  W !!!
  1.  S X=0 F  S X=$O(^APCMMUCN(APCMRPTC,11,X)) Q:X'=+X  W ^APCMMUCN(APCMRPTC,11,X,0),!
  1.  S DIR(0)="Y",DIR("A")="Do you wish to continue to report",DIR("B")="YES" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) D XIT Q
  1.  I 'Y D XIT Q
  1.  ;gather up measures for this report
  1.  S X=0 F  S X=$O(^APCM14OB(X)) Q:X'=+X  I $P(^APCM14OB(X,0),U,2)="E" S APCMIND(X)=""
  1. RT ;
  1.  S APCMSUM="S"
  1. TP ;
  1.  S APCMRPTP=""
  1.  ;W !!,"Report may be run for a quarter, 90-days, a one year or a user defined period."
  1.  ;display note
  1.  W !!
  1.  S X=0 F  S X=$O(^APCMMUCN(APCMRPTC,17,X)) Q:X'=+X  W ^APCMMUCN(APCMRPTC,17,X,0),!
  1. YEAR ;
  1.  S (APCMPER,APCMVDT,APCMBD,APCMED)=""
  1.  W !!,"Enter the Calendar Year for which report is to be run.  Use a 4 digit",!,"year, e.g. 2014."
  1.  S DIR(0)="D^::EP"
  1.  S DIR("A")="Enter the Calendar Year"
  1.  S DIR("?")="This report is compiled for a period.  Enter a valid year."
  1.  D ^DIR KILL DIR
  1.  I $D(DIRUT) G INTRO
  1.  I $D(DUOUT) S DIRUT=1 G INTRO
  1.  S APCMVDT=Y
  1.  I $E(Y,4,7)'="0000" W !!,"Please enter a year only!",! G YEAR
  1.  S APCMPER=APCMVDT
  1.  S APCMQ=0
  1.  I APCMPER'="3150000"  D  G:APCMQ YEAR
  1.  .W !!,"Select one of the following:",!
  1.  .W !?10,"1  Quarter: January 1 - March 31"
  1.  .W !?10,"2  Quarter: April 1 - June 30"
  1.  .W !?10,"3  Quarter: July 1 - September 30"
  1.  .W !?10,"4  Quarter: October 1 - December 31"
  1.  .W !?10,"5  User Defined 90-Day Report"
  1.  .W !?10,"6  User Defined Date Range"
  1.  .S DIR(0)="N^1:6:",DIR("A")="Select Report Period" KILL DA D ^DIR KILL DIR
  1.  .I $D(DIRUT) S APCMQ=1
  1.  .S APCMRPTP=Y
  1.  .I APCMRPTP=1 S APCMBD=$E(APCMPER,1,3)_"0101",APCMED=$E(APCMPER,1,3)_"0331" Q
  1.  .I APCMRPTP=2 S APCMBD=$E(APCMPER,1,3)_"0401",APCMED=$E(APCMPER,1,3)_"0630" Q
  1.  .I APCMRPTP=3 S APCMBD=$E(APCMPER,1,3)_"0701",APCMED=$E(APCMPER,1,3)_"0930" Q
  1.  .I APCMRPTP=4 S APCMBD=$E(APCMPER,1,3)_"1001",APCMED=$E(APCMPER,1,3)_"1231" Q
  1.  .I APCMRPTP=5 D 5 Q
  1.  .I APCMRPTP=6 D 6 Q
  1.  I APCMPER="3150000"  D  G:APCMQ YEAR
  1.  .W !!,"Select one of the following:",!
  1.  .W !?10,"1  Year: January 1 - December 31"
  1.  .W !?10,"2  User Defined 90-Day Report"
  1.  .W !?10,"3  User Defined Date Range"
  1.  .S DIR(0)="N^1:3:",DIR("A")="Select Report Period" KILL DA D ^DIR KILL DIR
  1.  .I $D(DIRUT) S APCMQ=1
  1.  .S APCMRPTP=Y
  1.  .I APCMRPTP=1 S APCMBD=$E(APCMPER,1,3)_"0101",APCMED=$E(APCMPER,1,3)_"1231" Q
  1.  .I APCMRPTP=2 D 5 Q
  1.  .I APCMRPTP=3 D 6 Q
  1.  I APCMBD="" G TP
  1.  I APCMED="" G TP
  1.  ;S X=$O(^APCM14OB("B","S1.002.EP",0))
  1.  ;S APCMQ=""
  1.  ;I $D(APCMIND(X)),($P($G(^APCCCTRL(DUZ(2),"MU")),U,1)=""!($P($G(^APCCCTRL(DUZ(2),"MU")),U,1)'<APCMBD)) D  G:APCMQ XIT
  1.  ;.S APCMQ=""
  1.  ;.W !!,"You have chosen to run the Drug Interaction Checks Measure."
  1.  ;.W !,"Warning: Your MU Clean Date for this measure is either blank"
  1.  ;.W !,"or set to a date that is after the beginning date of the report"
  1.  ;.W !,"period.  Therefore, you will not meet this measure."
  1.  ;.S DIR(0)="Y",DIR("A")="Do you wish to continue to run this report",DIR("B")="YES" KILL DA D ^DIR KILL DIR
  1.  ;.I $D(DIRUT) S APCMQ=1 Q
  1.  ;.I 'Y S APCMQ=1 Q
  1. PRV ;
  1.  S APCMPLTY=""
  1.  S DIR(0)="S^IP:Individual Provider;SEL:Selected Providers (User Defined);TAX:Provider Taxonomy List",DIR("A")="Enter Selection" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) G TP
  1.  S APCMPLTY=Y
  1.  S APCMQUIT=""
  1.  I APCMPLTY="IP" D  I $G(APCMQUIT) G PRV
  1.  .K APCMPRV
  1.  .W !!,"Enter the name of the provider for whom the Meaningful Use Report will be run.",!
  1.  .S DIC="^VA(200,",DIC(0)="AEMQ",D="AK.PROVIDER",DIC("A")="Enter PROVIDER NAME: " D MIX^DIC1 K DIC,D
  1.  .I Y<0 S APCMQUIT=1 Q
  1.  .S APCMPRV(+Y)=""
  1.  I APCMPLTY="SEL" D  I $G(APCMQUIT) G PRV
  1.  .K APCMPRV
  1.  .W !!,"Enter the name of the provider for whom the Meaningful Use Report will be run.",!
  1. SEL1 .S DIC="^VA(200,",DIC(0)="AEMQ",D="AK.PROVIDER",DIC("A")="Enter PROVIDER NAME: " D MIX^DIC1 K DIC,D
  1.  .I Y<0,'$D(APCMPRV) S APCMQUIT=1 Q
  1.  .I Y<0 Q
  1.  .S APCMPRV(+Y)=""
  1.  .G SEL1
  1.  I APCMPLTY="TAX" D  I $G(APCMQUIT) G PRV
  1.  .W !!,"Enter the name of the provider taxonomy"
  1.  .S DIC="^ATXAX(",DIC("S")="I $P(^(0),U,15)=200",DIC(0)="AEMQ",DIC("A")="Enter PROVIDER TAXONOMY NAME: " D ^DIC K DIC
  1.  .I Y<0 S APCMQUIT=1 Q
  1.  .S APCMPRTX=+Y
  1.  .W !,"The following providers are members of this taxonomy: "
  1.  .S X=0 F  S X=$O(^ATXAX(+Y,21,"B",X)) Q:X'=+X  S APCMPRV(X)="" W !?5,"- ",$P(^VA(200,X,0),U,1)
  1. DEMO ;
  1.  D DEMOCHK^APCLUTL(.APCMDEMO)
  1.  I APCMDEMO=-1 G PRV
  1. ASKADD ;
  1.  K APCMADDQ,APCMATTE
  1.  S A=$O(^APCM14OB("B","S1.008.EP",0))
  1.  S B=$O(^APCM14OB("B","S1.003.EP",0))
  1.  S C=$O(^APCM14OB("B","S1.020.EP",0))
  1.  I '$D(APCMIND(A)),'$D(APCMIND(B)),'$D(APCMIND(C)) G ATTEST
  1.  W !!,"Please answer the following exclusion questions for each provider."
  1.  D EPRES ;ASK ADDITIONAL QUESTIONS FOR E-PRESCRIBING
  1.  I APCMQ G DEMO
  1.  D VITALS ;ASK ADDITIONAL QUESTIONS FOR VITALS
  1.  I APCMQ G ASKADD
  1.  D VDT^APCM14E1
  1.  I APCMQ G ASKADD
  1. ATTEST ;get answers to attestation questions for each provider.
  1.  D ATTESTQ
  1.  I APCMQ G ASKADD
  1. SUM ;display summary of this report
  1.  W:$D(IOF) @IOF
  1.  W !,$$CTR("SUMMARY OF STAGE 1 2014/2015 MEANINGFUL USE REPORT TO BE GENERATED")
  1.  W !!,"The date ranges for this report are:"
  1.  W !?5,"Report Period: ",?31,$$FMTE^XLFDT(APCMBD)," to ",?31,$$FMTE^XLFDT(APCMED)
  1.  W !!,"Providers: "
  1.  S X=0 F  S X=$O(APCMPRV(X)) Q:X'=+X  W !?5,$P(^VA(200,X,0),U,1)
  1.  D PT^APCM14SL
  1.  I APCMROT="" G DEMO
  1. ZIS ;call to XBDBQUE
  1.  D REPORT^APCM14SL
  1.  I $G(APCMQUIT) D XIT Q
  1.  I APCMRPT="" D XIT Q
  1.  K IOP,%ZIS I APCMROT="D",APCMDELT="F" D NODEV,XIT Q
  1.  K IOP,%ZIS W !! S %ZIS=$S(APCMDELT'="S":"PQM",1:"PM") D ^%ZIS
  1.  I POP W !,"Report Aborted" S DA=APCMRPT,DIK="^APCMM14C(" D ^DIK K DIK D XIT Q
  1.  I $D(IO("Q")) G TSKMN
  1. DRIVER ;
  1.  D PROC^APCM14E1
  1.  U IO
  1.  D ^APCM14EP
  1.  D ^%ZISC
  1.  D XIT
  1.  Q
  1.  ;
  1. NODEV ;
  1.  S XBRP="",XBRC="NODEV1^APCM14E",XBRX="XIT^APCM14E",XBNS="APCM"
  1.  D ^XBDBQUE
  1.  Q
  1.  ;
  1. NODEV1 ;
  1.  D PROC^APCM14E1
  1.  D ^APCM14EP
  1.  D ^%ZISC
  1.  D XIT
  1.  Q
  1. TSKMN ;EP ENTRY POINT FROM TASKMAN
  1.  S ZTIO=$S($D(ION):ION,1:IO) I $D(IOST)#2,IOST]"" S ZTIO=ZTIO_";"_IOST
  1.  I $G(IO("DOC"))]"" S ZTIO=ZTIO_";"_$G(IO("DOC"))
  1.  I $D(IOM)#2,IOM S ZTIO=ZTIO_";"_IOM I $D(IOSL)#2,IOSL S ZTIO=ZTIO_";"_IOSL
  1.  K ZTSAVE S ZTSAVE("APCM*")=""
  1.  S ZTCPU=$G(IOCPU),ZTRTN="DRIVER^APCM14E",ZTDTH="",ZTDESC="2014 MU STAGE 1 REPORT" D ^%ZTLOAD D XIT Q
  1.  Q
  1.  ;
  1. XIT ;
  1.  D ^%ZISC
  1.  D EN^XBVK("APCM")
  1.  I $D(ZTQUEUED) S ZTREQ="@"
  1.  K DIRUT,DUOUT,DIR,DOD
  1.  K DIADD,DLAYGO
  1.  D KILL^AUPNPAT
  1.  K X,X1,X2,X3,X4,X5,X6
  1.  K A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,V,W,X,Y,Z
  1.  K N,N1,N2,N3,N4,N5,N6
  1.  K BD,ED
  1.  D KILL^AUPNPAT
  1.  D ^XBFMK
  1.  Q
  1.  ;
  1. CTR(X,Y) ;EP - Center X in a field Y wide.
  1.  Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
  1.  ;----------
  1. EOP ;EP - End of page.
  1.  Q:$E(IOST)'="C"
  1.  Q:$D(ZTQUEUED)!$D(IO("S"))
  1.  NEW DIR
  1.  K DIR,DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
  1.  S DIR(0)="E" D ^DIR KILL DIR
  1.  Q
  1.  ;----------
  1. USR() ;EP - Return name of current user from ^VA(200.
  1.  Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
  1.  ;----------
  1. LOC() ;EP - Return location name from file 4 based on DUZ(2).
  1.  Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
  1.  ;----------
  1.  ;
  1. 5 ;
  1. B ;
  1.  W !
  1.  S (APCMPER,APCMVDT,APCMBD,APCMED)=""
  1.  W ! K DIR,X,Y S DIR(0)="D^::EP",DIR("A")="Enter Start Date for the 90-Day Report (e.g. 01/01/2014)" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  I $D(DIRUT) Q
  1.  S (APCMPER,APCMVDT)=Y
  1.  S APCMBD=Y,APCMED=$$FMADD^XLFDT(APCMBD,89)
  1.  Q
  1. 6 ;EP
  1. C ;EP
  1.  S (APCMPER,APCMVDT,APCMBD,APCMED)=""
  1.  K DIR W ! S DIR(0)="DO^::EXP",DIR("A")="Enter Beginning Date"
  1.  D ^DIR G:Y<1 CXIT
  1.  I Y>DT W !!,"Future dates not allowed." G C
  1.  S APCMBD=Y
  1.  K DIR S DIR(0)="DO^:DT:EXP",DIR("A")="Enter Ending Date"
  1.  D ^DIR G:Y<1 C  S APCMED=Y
  1.  ;
  1.  I APCMED<APCMBD D  G C
  1.  . W !!,$C(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
  1.  Q
  1. CXIT ;
  1.  K DIR
  1.  Q
  1. EPRES ;EP - ask additional exclusion questions for e-prescribing
  1.  S APCMQ=0
  1.  S APCMY=$O(^APCM14OB("B","S1.003.EP",0))
  1.  Q:'$D(APCMIND(APCMY))  ;measure not being run
  1.  K APCMADDQ("ANS",APCMY)
  1.  ;display exclusion text/narrative
  1.  I $O(^APCM14OB(APCMY,26,0)) D ET
  1.  I APCMPLTY="SEL"!(APCMPLTY="TAX") D  G:APCMIND=1 EIND Q
  1.  .S APCMQ=0,APCMIND=0
  1.  .W !,"The e-Prescribing onsite pharmacy question below may be addressed as a group or"
  1.  .W !,"by individual provider. Do you want to answer for all selected providers as a"
  1.  .S DIR(0)="Y",DIR("A")="group Y/N",DIR("B")="YES" KILL DA D ^DIR KILL DIR
  1.  .I $D(DIRUT) S APCMQ=1 Q
  1.  .I 'Y S APCMIND=1 Q
  1.  .W !!,"Do all selected providers included in this report have an onsite"
  1.  .S DIR(0)="Y",DIR("A")="pharmacy Y/N",DIR("B")="YES" KILL DA D ^DIR KILL DIR
  1.  .I $D(DIRUT) S APCMQ=1 Q
  1.  .I 'Y S APCMIND=1 Q
  1.  .S APCMP=0 F  S APCMP=$O(APCMPRV(APCMP)) Q:APCMP'=+APCMP  S APCMADDQ("ANS",APCMY,24,APCMP)="Yes"
  1. EIND ;ask individually
  1.  S APCMP=0 F  S APCMP=$O(APCMPRV(APCMP)) Q:APCMP'=+APCMP!(APCMQ)  D
  1.  .S APCMZ=0 F  S APCMZ=$O(^APCM14OB(APCMY,24,APCMZ)) Q:APCMZ'=+APCMZ  W !,^APCM14OB(APCMY,24,APCMZ,0)
  1.  .S DIR(0)="Y",DIR("A")=$E($P(^VA(200,APCMP,0),U,1),1,25)_"'s answer",DIR("B")="YES" KILL DA D ^DIR KILL DIR
  1.  .I $D(DIRUT) S APCMQ=1 Q
  1.  .S APCMADDQ("ANS",APCMY,24,APCMP)=$S(Y:"Yes",1:"No")
  1.  .Q:Y
  1.  .W ! S X=0 F  S X=$O(^APCM14OB(APCMY,25,X)) Q:X'=+X  W !,^APCM14OB(APCMY,25,X,0)
  1.  .;S APCMP=0 F  S APCMP=$O(APCMPRV(APCMP)) Q:APCMP'=+APCMP!(APCMQ)  D
  1.  .S DIR(0)="Y",DIR("A")=$E($P(^VA(200,APCMP,0),U,1),1,25)_"'s answer",DIR("B")="YES" KILL DA D ^DIR KILL DIR
  1.  .I $D(DIRUT) S APCMQ=1 Q
  1.  .S APCMADDQ("ANS",APCMY,25,APCMP)=$S(Y:"Yes",1:"No")
  1.  Q
  1. ET ;
  1.  W ! S APCMZ=0 F  S APCMZ=$O(^APCM14OB(APCMY,26,APCMZ)) Q:APCMZ'=+APCMZ  W !,^APCM14OB(APCMY,26,APCMZ,0)
  1.  W !
  1.  Q
  1. VITALS ;EP - VITALS QUESTIONS
  1.  S APCMQ=0
  1.  S APCMY=$O(^APCM14OB("B","S1.008.EP",0))
  1.  Q:'$D(APCMIND(APCMY))  ;measure not being run
  1.  K APCMADDQ("ANS",APCMY)
  1.  ;display exclusion text/narrative
  1.  I $O(^APCM14OB(APCMY,26,0)) D ET
  1. VIND ;ask individually
  1.  S APCMP=0 F  S APCMP=$O(APCMPRV(APCMP)) Q:APCMP'=+APCMP!(APCMQ)  D
  1.  .W ! S APCMZ=0 F  S APCMZ=$O(^APCM14OB(APCMY,24,APCMZ)) Q:APCMZ'=+APCMZ  W !,^APCM14OB(APCMY,24,APCMZ,0)
  1.  .S DIR(0)="Y",DIR("A")=$E($P(^VA(200,APCMP,0),U,1),1,25)_"'s answer",DIR("B")="NO" KILL DA D ^DIR KILL DIR
  1.  .I $D(DIRUT) S APCMQ=1 Q
  1.  .S APCMADDQ("ANS",APCMY,24,APCMP)=$S(Y:"Yes",1:"No")
  1.  .Q:Y
  1.  .W ! S X=0 F  S X=$O(^APCM14OB(APCMY,25,X)) Q:X'=+X  W !,^APCM14OB(APCMY,25,X,0)
  1.  .S DIR(0)="Y",DIR("A")=$E($P(^VA(200,APCMP,0),U,1),1,25)_"'s answer",DIR("B")="NO" KILL DA D ^DIR KILL DIR
  1.  .I $D(DIRUT) S APCMQ=1 Q
  1.  .S APCMADDQ("ANS",APCMY,25,APCMP)=$S(Y:"Yes",1:"No")
  1.  .Q:Y
  1.  .W ! S X=0 F  S X=$O(^APCM14OB(APCMY,27,X)) Q:X'=+X  W !,^APCM14OB(APCMY,27,X,0)
  1.  .S DIR(0)="Y",DIR("A")=$E($P(^VA(200,APCMP,0),U,1),1,25)_"'s answer",DIR("B")="NO" KILL DA D ^DIR KILL DIR
  1.  .I $D(DIRUT) S APCMQ=1 Q
  1.  .S APCMADDQ("ANS",APCMY,27,APCMP)=$S(Y:"Yes",1:"No")
  1.  .Q:Y
  1.  .W ! S X=0 F  S X=$O(^APCM14OB(APCMY,28,X)) Q:X'=+X  W !,^APCM14OB(APCMY,28,X,0)
  1.  .S DIR(0)="Y",DIR("A")=$E($P(^VA(200,APCMP,0),U,1),1,25)_"'s answer",DIR("B")="NO" KILL DA D ^DIR KILL DIR
  1.  .I $D(DIRUT) S APCMQ=1 Q
  1.  .S APCMADDQ("ANS",APCMY,28,APCMP)=$S(Y:"Yes",1:"No")
  1.  Q
  1. ATTESTQ ;EP
  1.  S APCMQ=0
  1.  S Z=0 F  S Z=$O(^APCM14OB("EOORDER",Z)) Q:Z'=+Z  S X=$O(^APCM14OB("EOORDER",Z,0)) I $D(APCMIND(X)),$P(^APCM14OB(X,0),U,17) S X=$P(^APCM14OB(X,0),U,1) D
  1.  .S Y=0 F  S Y=$O(APCMPRV(Y)) Q:Y'=+Y  S APCMATTE(X,Y)=""
  1.  I '$D(APCMATTE) Q  ;no measures with attestation being run
  1.  W !!,"Several Stage 1 Meaningful Use Performance Measures require an attestation of "
  1.  W !,"Yes or No for each provider for which the report is being run.",!
  1.  S DIR(0)="Y",DIR("A")="Do you wish to continue",DIR("B")="YES" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) S APCMQ=1 Q
  1.  I 'Y S APCMQ=1 Q
  1.  S APCMQ=0
  1.  I APCMPLTY="SEL"!(APCMPLTY="TAX") D
  1.  .W !!,"Each of the questions below may be addressed as a group or individual",!,"attestation.",!
  1.  S APCMX="" F  S APCMX=$O(APCMATTE(APCMX)) Q:APCMX=""!(APCMQ)  D
  1.  .;WRITE QUESTION
  1.  .Q:APCMX="S1.020.EP.1"
  1.  .W !
  1.  .S APCMY=$O(^APCM14OB("B",APCMX,0))
  1.  .S X=0 F  S X=$O(^APCM14OB(APCMY,19,X)) Q:X'=+X  W !,^APCM14OB(APCMY,19,X,0)
  1.  .I APCMPLTY="SEL"!(APCMPLTY="TAX") D  G:APCMIND ATTIND Q
  1.  ..S APCMIND=0
  1.  ..I '$P(^APCM14OB(APCMY,0),U,13) D
  1.  ...W ! S DIR(0)="Y",DIR("A")="Do all selected providers included in this report attest to this",DIR("B")="YES" KILL DA D ^DIR KILL DIR
  1.  ...I $D(DIRUT) S APCMQ=1 Q
  1.  ...I 'Y S APCMIND=1 Q
  1.  ...S APCMP=0 F  S APCMP=$O(APCMPRV(APCMP)) Q:APCMP'=+APCMP  S APCMATTE(APCMX,APCMP)="Yes"
  1.  ..I $P(^APCM14OB(APCMY,0),U,13) D
  1.  ...W ! S DIR(0)="Y",DIR("A")="Will the following response apply to all EPs included in this report",DIR("B")="YES" KILL DA D ^DIR KILL DIR
  1.  ...I $D(DIRUT) S APCMQ=1 Q
  1.  ...I 'Y S APCMIND=1 Q
  1.  ...S DIR(0)="S^Y:YES;N:NO;X:No Registry Available",DIR("A")="All selected providers included in this report attest to (Enter Y, N or X)",DIR("B")="YES" KILL DA D ^DIR KILL DIR
  1.  ...I $D(DIRUT) S APCMQ=1 Q
  1.  ...S APCMP=0 F  S APCMP=$O(APCMPRV(APCMP)) Q:APCMP'=+APCMP  S APCMATTE(APCMX,APCMP)=$S(Y="X":"N/A",Y="Y":"Yes",Y="N":"No",Y:"Yes",1:"No")
  1. ATTIND .;
  1.  .S APCMP=0 F  S APCMP=$O(APCMPRV(APCMP)) Q:APCMP'=+APCMP!(APCMQ)  D
  1.  ..I '$P(^APCM14OB(APCMY,0),U,13) S DIR(0)="Y",DIR("A")="Does "_$E($P(^VA(200,APCMP,0),U,1),1,25)_" attest to this",DIR("B")="YES" KILL DA D ^DIR KILL DIR
  1.  ..I $P(^APCM14OB(APCMY,0),U,13) S DIR(0)="S^Y:YES;N:NO;X:No Registry Available",DIR("A")="Does "_$E($P(^VA(200,APCMP,0),U,1),1,25)_" attest to this",DIR("B")="YES" KILL DA D ^DIR KILL DIR
  1.  ..I $D(DIRUT) S APCMQ=1 Q
  1.  ..S APCMATTE(APCMX,APCMP)=$S(Y="X":"N/A",Y="Y":"Yes",Y="N":"No",Y:"Yes",1:"No")
  1.  Q