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

APCSCERT.m

Go to the documentation of this file. 
  1. APCSCERT ; IHS/CMI/LAB - APCS Certification Export ; 
  1.  ;;2.0;IHS PCC SUITE;**6**;MAY 14, 2009;Build 11
  1.  ;
  1.  ;
  1. START ;
  1.  ;This option will create an HL7 o output file of all visits in a date range that have a certain lab test.
  1.  ;
  1.  ;
  1.  D EXIT
  1.  ;
  1. INFORM ;inform user
  1.  W:$D(IOF) @IOF
  1.  W !!,$$CJ^XLFSTR("EPI PROGRAM HL7 LAB EXPORT",80)
  1.  W !!,"This option is used to create a file of HL7 messages.  These messages will"
  1.  W !,"be sent to the IHS Certification program.  A message will be sent for every visit"
  1.  W !,"on which a certain lab test was done.  The user will define the date range"
  1.  W !,"of visits to export."
  1.  W !,"This HL7 export file will be automatically ftp'ed to the EPI program.",!!
  1. DATES ;set date range to T-91 to T-1
  1.  S (APCSSD,APCSED)=""
  1. BD ;get beginning date
  1.  W ! S DIR(0)="D^:DT:EP",DIR("A")="Enter Beginning Visit Date" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  I $D(DIRUT) G EXIT
  1.  S APCSBD=Y
  1. ED ;get ending date
  1.  W ! S DIR(0)="DA^"_APCSBD_":DT:EP",DIR("A")="Enter Ending Visit Date: " S Y=APCSBD D DD^%DT S Y="" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  I $D(DIRUT) G BD
  1.  S APCSED=Y
  1.  S X1=APCSBD,X2=-1 D C^%DTC S APCSSD=X_".9999"
  1.  ;
  1.  W !!,"The date range for this export is: ",$$FMTE^XLFDT(APCSBD)," to ",$$FMTE^XLFDT(APCSED),".",!
  1. LABTYPE ;
  1.  S APCSLTYP=""
  1.  S DIR(0)="S^A:Rapid Test for Influenza A & B;B:Chlamydia Tests;C:Both A & B;D:Any Lab Test or Set of (Taxonomy) Lab Tests",DIR("A")="Which Lab Tests should Trigger an HL7 message to be generated"
  1.  KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) G DATES
  1.  S APCSLTYP=Y
  1.  S APCLQ=""
  1.  I APCSLTYP="A"!(APCSLTYP="C") D A G:APCLQ LABTYPE
  1.  I APCSLTYP="B"!(APCSLTYP="C") D B G:APCLQ LABTYPE
  1.  I APCSLTYP="D" D D G:APCLQ LABTYPE
  1. CONTINUE ;
  1.  W !!
  1.  S DIR(0)="Y",DIR("A")="Do you wish to continue and generate this export file",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  I 'Y D EXIT Q
  1. ZIS ;called xbdbque to see if they want to queue or not
  1. DEMO ;
  1.  D DEMO^APCLUTL(.APCLDEMO)
  1.  I $G(APCLDEMO) G LABTYPE
  1.  S XBRC="PROC^APCSCERT",XBRP="",XBNS="APCS",XBRX="EXIT^APCSCERT"
  1.  D ^XBDBQUE
  1.  D EXIT
  1.  Q
  1. A ;
  1.  S APCSALBT=$O(^ATXLAB("B","SURVEILLANCE RAPID FLU TESTS",0))
  1.  I 'APCSALBT W !!,"The SURVEILLANCE RAPID FLU TESTS lab taxonomy is missing.  Cannot continue." S APCLQ=1 Q
  1.  S APCSACTT=$O(^ATXAX("B","SURVEILLANCE RAPID FLU CPT",0)) I 'APCSACTT W !!,"The SURVEILLANCE RAPID FLU CPT taxonomy is missing.  Cannot continue." S APCLQ=1 Q
  1.  S APCSALOT=$O(^ATXAX("B","SURVEILLANCE RAPID FLU LOINC",0))
  1.  I 'APCSALOT W !!,"The SURVEILLANCE RAPID FLU LOINC taxonomy is missing.  Cannot continue." S APCLQ=1 Q
  1.  I '$O(^ATXLAB(APCSALBT,21,0)) W !!,"The SURVEILLANCE RAPID FLU TESTS site populated LAB taxonomy has no entries." S APCLQ=1 Q
  1.  Q
  1. B ;
  1.  S APCSBLBT=$O(^ATXLAB("B","BGP CHLAMYDIA TESTS TAX",0))
  1.  I 'APCSBLBT W !!,"The BGP CHLAMYDIA TESTS TAX lab taxonomy is missing.  Cannot continue." S APCLQ=1 Q
  1.  S APCSBCTT=$O(^ATXAX("B","BGP CHLAMYDIA CPTS",0)) I 'APCSBCTT W !!,"The CHLAMYDIA CPT taxonomy is missing.  Cannot continue." S APCLQ=1 Q
  1.  S APCSBLOT=$O(^ATXAX("B","BGP CHLAMYDIA LOINC CODES",0))
  1.  I 'APCSBLOT W !!,"The BGP CHLAMYDIA LOINC CODES taxonomy is missing.  Cannot continue." S APCLQ=1 Q
  1.  I '$O(^ATXLAB(APCSBLBT,21,0)) W !!,"The BGP CHLAMYDIA TESTS TAX site populated LAB taxonomy has no entries." S APCLQ=1 Q
  1.  Q
  1. LABTAX ;
  1.  S DIC="^ATXLAB(",DIC(0)="AEMQ" D ^DIC
  1.  I Y=-1 Q
  1.  S X=0 F  S X=$O(^ATXLAB(+Y,21,X)) Q:X'=+X  S L=$P(^ATXLAB(+Y,21,X,0),U,1) I $D(^LAB(60,L,0)) S APCSLABS(L)=""
  1.  Q
  1. INDLAB ;
  1.  S DIC=60,DIC(0)="AEMQ" D ^DIC
  1.  I Y=-1 Q
  1.  S APCSLABS(+Y)=""
  1.  G INDLAB
  1. D ;taxonomy or selected
  1.  K APCSLABS
  1.  S APCSLABS=""
  1.  S DIR(0)="S^I:Select Lab Tests Individually by Name;T:Use a Lab Taxonomy",DIR("A")="How do you want to select Lab Tests for Export",DIR("B")="I" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) S APCLQ=1 Q
  1.  S APCSLABS=Y
  1.  I APCSLABS="T" D LABTAX
  1.  I APCSLABS="I" D INDLAB
  1.  I '$O(APCSLABS(0)) S APCLQ=1 K APCSLABS W !!,"no lab tests selected." Q
  1.  W !!,"The following labs and values will be exported:"
  1.  S X=0 F  S X=$O(APCSLABS(X)) Q:X'=+X  W !?5,$P(^LAB(60,X,0),U,1)
  1.  W !
  1.  Q
  1. PROC ;EP - called from xbdbque
  1.  W:'$D(ZTQUEUED) !,"Processing..."
  1.  K ^APCSDATA($J)
  1.  S APCSVTOT=0
  1.  F  S APCSSD=$O(^AUPNVSIT("B",APCSSD)) Q:APCSSD'=+APCSSD!($P(APCSSD,".")>APCSED)  D
  1.  .S APCSV=0 F  S APCSV=$O(^AUPNVSIT("B",APCSSD,APCSV)) Q:APCSV'=+APCSV  D
  1.  ..Q:'$D(^AUPNVSIT(APCSV,0))  ;no zero node
  1.  ..Q:$P(^AUPNVSIT(APCSV,0),U,11)  ;deleted visit
  1.  ..S DFN=$P(^AUPNVSIT(APCSV,0),U,5)
  1.  ..Q:DFN=""
  1.  ..Q:'$D(^DPT(DFN,0))
  1.  ..Q:$P(^DPT(DFN,0),U)["DEMO,PATIENT"
  1.  ..Q:$$DEMO^APCLUTL(DFN)
  1.  ..;check for tests
  1.  ..S APCSGOT="" K APCSLABT
  1.  ..D LAB
  1.  ..I APCSGOT D CERT^APCSHLOC(.APCSLAB,"CERT")
  1.  ..S APCSVTOT=1
  1.  ..Q
  1.  .Q
  1.  I 'APCSVTOT D
  1.  .Q:$D(ZTQUEUED)
  1.  .W !!,"There are no lab test results to export."
  1.  .D PAUSE^APCLVL01
  1.  Q
  1. LAB ;does this visit have A or B or either?
  1.  S X=0 F  S X=$O(^AUPNVLAB("AD",APCSV,X)) Q:X'=+X  D
  1.  .Q:'$D(^AUPNVLAB(X,0))
  1.  .I '$P(^AUPNVLAB(X,0),U,1) Q
  1.  .I APCSLTYP="A"!(APCSLTYP="C") D
  1.  ..I $D(^ATXLAB(APCSALBT,21,"B",$P(^AUPNVLAB(X,0),U))) S APCSGOT=1,APCSLAB(X)="" Q
  1.  ..Q:'APCSALOT
  1.  ..S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ..Q:'$$LOINC(J,APCSALOT)
  1.  ..S APCSGOT=1,APCSLAB(X)=""
  1.  .I APCSLTYP="B"!(APCSLTYP="C") D
  1.  ..I $D(^ATXLAB(APCSBLBT,21,"B",$P(^AUPNVLAB(X,0),U))) S APCSGOT=1,APCSLAB(X)="" Q
  1.  ..Q:'APCSBLOT
  1.  ..S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ..Q:'$$LOINC(J,APCSBLOT)
  1.  ..S APCSGOT=1,APCSLAB(X)=""
  1.  .I APCSLTYP="D"  D
  1.  ..I '$D(APCSLABS($P(^AUPNVLAB(X,0),U))) Q
  1.  ..S APCSGOT=1,APCSLAB(X)=""
  1.  Q
  1. LOINC(A,B) ;EP
  1.  NEW %
  1.  S %=$P($G(^LAB(95.3,A,9999999)),U,2)
  1.  I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
  1.  S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
  1.  I $D(^ATXAX(B,21,"B",%)) Q 1
  1.  Q ""
  1.  ;send file
  1. WRITE ; use XBGSAVE to save the temp global (APCSDATA) to a delimited
  1.  ; file that is exported to the IE system
  1.  N XBGL,XBQ,XBQTO,XBNAR,XBMED,XBFLT,XBUF,XBFN
  1.  S XBGL="APCSDATA",XBMED="F",XBQ="N",XBFLT=1,XBF=$J,XBE=$J
  1.  S XBNAR="CERTIFICATION EXPORT"
  1.  S APCSASU=$P($G(^AUTTLOC($P(^AUTTSITE(1,0),U),0)),U,10)  ;asufac for file name
  1.  S XBFN="CERTLABHL7_"_APCSASU_"_"_$$DATE(DT)_".txt"
  1.  S XBS1="CERTIFICATION EXPORT"
  1.  ;
  1.  D ^XBGSAVE
  1.  ;
  1.  I XBFLG'=0 D
  1.  . I XBFLG(1)="" W:'$D(ZTQUEUED) !!,"LAB HL7 file successfully created",!!
  1.  . I XBFLG(1)]"" W:'$D(ZTQUEUED) !!,"LAB HL7 file NOT successfully created",!!
  1.  . W:'$D(ZTQUEUED) !,"File was NOT successfully transferred to IHS/CDC",!,"you will need to manually ftp it.",!
  1.  . W:'$D(ZTQUEUED) !,XBFLG(1),!!
  1.  K ^APCSDATA($J)
  1.  Q
  1.  ;
  1. DATE(D) ;EP
  1.  Q (1700+$E(D,1,3))_$E(D,4,5)_$E(D,6,7)
  1.  ;
  1. JDATE(D) ;EP - get date
  1.  I $G(D)="" Q ""
  1.  NEW A
  1.  S A=$$FMTE^XLFDT(D)
  1.  Q $E(D,6,7)_$$UP^XLFSTR($P(A," ",1))_(1700+$E(D,1,3))
  1.  ;
  1. UID(APCSA) ;Given DFN return unique patient record id.
  1.  I '$G(APCSA) Q ""
  1.  I '$D(^AUPNPAT(APCSA)) Q ""
  1.  ;
  1.  Q $$GET1^DIQ(9999999.06,$P(^AUTTSITE(1,0),U),.32)_$E("0000000000",1,10-$L(APCSA))_APCSA
  1.  ;
  1. EXIT ;clean up and exit
  1.  D EN^XBVK("APCS")
  1.  D ^XBFMK
  1.  Q
  1.  ;
  1. EP ;EP - called from option to create search template using ILI logic
  1.  G ^APCLSIL3
  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)!'(IOT["TRM")!$D(IO("S"))
  1.  NEW DIR
  1.  K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
  1.  S DIR(0)="E" D ^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. PURGE ;
  1.  W:'$D(ZTQUEUED) !!,"Now cleaning up host files older than 7 DAYS"
  1.  K APCSFILE,APCSDIR
  1.  S APCSDIR=$P($G(^AUTTSITE(1,1)),"^",2)
  1.  I APCSDIR="" S APCSDIR=$P($G(^XTV(8989.3,1,"DEV")),"^",1)
  1.  I APCSDIR="" Q
  1.  S APCSASU=$P($G(^AUTTLOC($P(^AUTTSITE(1,0),U),0)),U,10)
  1.  S APCSDT=$$FMADD^XLFDT(DT,-7)
  1.  S APCSDT=$$DATE(APCSDT)
  1.  S APCSFLST=$$LIST^%ZISH(APCSDIR,"EPILABHL7"_APCSASU_"*",.APCSFILE)
  1.  Q:'$O(APCSFILE(""))
  1.  S APCSX=0 F  S APCSX=$O(APCSFILE(APCSX)) Q:APCSX'=+APCSX  D
  1.  .S D=$P($P(APCSFILE(APCSX),"."),"_",3)
  1.  .I D<APCSDT S N=APCSFILE(APCSX) S APCSM=$$DEL^%ZISH(APCSDIR,N)
  1.  Q