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

APCSSLAB.m

Go to the documentation of this file. 
  1. APCSSLAB ; IHS/CMI/LAB - ILI surveillance export ; 
  1.  ;;3.0;IHS PCC REPORTS;**22,23,24,25,26,27,28**;FEB 05, 1997
  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 EPI 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^APCSSLAB",XBRP="",XBNS="APCS",XBRX="EXIT^APCSSLAB"
  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 HL7(DFN,APCSV) Q  ;don't bother with cpts if found lab
  1.  ..S APCSGOT=0 K APCSLAB
  1.  ..D CPT
  1.  ..I APCSGOT D HL7(DFN,APCSV) Q
  1.  ..Q
  1.  .Q
  1.  I APCSVTOT D ILI^APCSHLO("ILILAB") 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. CPT ;
  1.  S X=0 F  S X=$O(^AUPNVCPT("AD",APCSV,X)) Q:X'=+X!(APCSGOT)  D
  1.  .Q:'$D(^AUPNVCPT(X,0))
  1.  .S Y=$P(^AUPNVCPT(X,0),U,1)
  1.  .I APCSLTYP="A"!(APCSLTYP="C"),$$ICD^ATXCHK(Y,APCSACTT,1) S APCSGOT=1 Q
  1.  .I APCSLTYP="B"!(APCSLTYP="C"),$$ICD^ATXCHK(Y,APCSBCTT,1) S APCSGOT=1 Q
  1.  .Q
  1.  Q
  1. HL7(FN,AV) ;export this visit - MARK - this is where you will generate the HL7 message
  1.  ;APCSV is visit ien
  1.  ;array APCSLAB is array of lab test entries to send from V LAB
  1.  ;if array APCSLAB is undefined that means a found a visit with a cpt code and no lab so there will be no OBXs for lab but send the visit
  1.  S APCSVTOT=APCSVTOT+1
  1.  D BLDPID(FN,AV)
  1.  D BLDZID(FN,AV)
  1.  D BLDPV1(AV)
  1.  D BLDDG1(AV)
  1.  D BLDPR1(AV)
  1.  S APCSOBXC=0
  1.  D BLDOBXTP(AV)
  1.  D BLDOBXLB(AV)
  1.  W:'$D(ZTQUEUED) ".",AV
  1.  Q
  1. BLDPID(F,V) ;
  1.  N LOC,HRN,SEX,DOB
  1.  S LOC=$P($G(^AUPNVSIT(V,0)),U,6)
  1.  S HRN=$S($$HRN^AUPNPAT(F,LOC)]"":$$HRN^AUPNPAT(F,LOC),1:$$HRN^AUPNPAT(F,DUZ(2)))
  1.  S SEX=$P($G(^DPT(F,0)),U,2)
  1.  S DOB=$$FMTHL7^XLFDT($P($G(^DPT(F,0)),U,3))
  1.  S ^APCSDATA($J,V,"PID")=HRN_U_SEX_U_DOB
  1.  Q
  1.  ;
  1. BLDZID(F,V) ;
  1.  N AGE
  1.  S AGE=$$AGE^AUPNPAT(F)
  1.  S ^APCSDATA($J,V,"ZID")=AGE
  1.  Q
  1.  ;
  1. BLDPV1(V) ;
  1.  N ASUFAC,UVIEN,VDT,DDT,LOC,CC,CLN
  1.  S LOC=$P($G(^AUPNVSIT(V,0)),U,6)
  1.  S CLN=$P($G(^AUPNVSIT(V,0)),U,8)
  1.  S CC=$S(CLN:$$GET1^DIQ(40.7,CLN,1),1:"")
  1.  S ASUFAC=$P(^AUTTLOC(LOC,0),U,10)
  1.  S UVIEN=$S($P($G(^AUPNVSIT(V,11)),U,14)]"":$P($G(^AUPNVSIT(V,11)),U,14),1:$$UIDV^AUPNVSIT(V))
  1.  S VDT=$$FMTHL7^XLFDT($P($P(^AUPNVSIT(V,0),U),"."))
  1.  S DDT=$$FMTHL7^XLFDT($$DSCHDATE^APCLSIL2(V))
  1.  S ^APCSDATA($J,V,"PV1")=ASUFAC_U_CC_U_UVIEN_U_VDT_U_DDT
  1.  Q
  1.  ;
  1. BLDDG1(V) ;
  1.  N BDA,DX,CNT
  1.  S CNT=0
  1.  S BDA=0 F  S BDA=$O(^AUPNVPOV("AD",V,BDA)) Q:'BDA  D
  1.  . S DX=$$GET1^DIQ(9000010.07,BDA,.01)
  1.  . S CNT=CNT+1
  1.  . S ^APCSDATA($J,V,"DG1",CNT)=DX
  1.  Q
  1.  ;
  1. BLDPR1(V) ;
  1.  N BDA,CPT,CNT
  1.  S CNT=0
  1.  S BDA=0 F  S BDA=$O(^AUPNVCPT("AD",V,BDA)) Q:'BDA  D
  1.  . S CPT=$$GET1^DIQ(9000010.18,BDA,.01)
  1.  . S CNT=CNT+1
  1.  . S ^APCSDATA($J,V,"PR1",CNT)=CPT
  1.  Q
  1.  ;
  1. BLDOBXTP(V) ;
  1.  N BDA,TMP,TEMP
  1.  S TEMP=""
  1.  S BDA=0 F  S BDA=$O(^AUPNVMSR("AD",V,BDA)) Q:'BDA  D
  1.  .Q:$P($G(^AUPNVMSR(BDA,2)),U,1)
  1.  .Q:$$VAL^XBDIQ1(9000010.01,BDA,.01)'="TMP"  ;not a temperature
  1.  .S TMP=$P(^AUPNVMSR(BDA,0),U,4)
  1.  .S TEMP=$S(TMP>TEMP:TMP,1:TEMP)
  1.  .S APCSOBXC=APCSOBXC+1
  1.  .S ^APCSDATA($J,V,"OBX",APCSOBXC)=APCSOBXC_U_"ST"_U_"TMP"_U_TEMP
  1.  Q
  1.  ;
  1. BLDOBXLB(V) ;
  1.  N BDA,LABI,LAB,LOINC,RES
  1.  S BDA=0 F  S BDA=$O(APCSLAB(BDA)) Q:'BDA  D
  1.  . S LABI=$P($G(^AUPNVLAB(BDA,0)),U)
  1.  . S RES=$P($G(^AUPNVLAB(BDA,0)),U,4)
  1.  . S LAB=$$GET1^DIQ(9000010.09,BDA,.01)
  1.  . S LOINC=$$GET1^DIQ(9000010.09,BDA,1113)
  1.  . S APCSOBXC=APCSOBXC+1
  1.  . S ^APCSDATA($J,V,"OBX",APCSOBXC)=APCSOBXC_U_"ST"_U_LOINC_"~"_LAB_U_RES
  1.  Q
  1.  ;
  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="EPI LAB HL7 EXPORT"
  1.  S APCSASU=$P($G(^AUTTLOC($P(^AUTTSITE(1,0),U),0)),U,10)  ;asufac for file name
  1.  S XBFN="EPILABHL7_"_APCSASU_"_"_$$DATE(DT)_".txt"
  1.  S XBS1="SURVEILLANCE ILI SEND"
  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