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

ACHSTX8.m

Go to the documentation of this file. 
  1. ACHSTX8 ; IHS/ITSC/PMF - EXPORT DATA (9/9) - EOJ ;JUL 10, 2008
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5,6,11,13,14,19,23,25**;JUN 11,2001;Build 43
  1.  ;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - Capture number of individual records.
  1.  ;IHS/SET/JVK ACHS*3.1*6 4/23/2003 - If site acts as area don't que file
  1.  ;ACHS*3.1*13 6.16.2007 IHS/OIT/FCJ Added new rec type of "U" and trans to Export status file
  1.  ;;ACHS*3.1*14 2.28.2008 IHS/OIT/FCJ Added test for OCC and Re-export option
  1.  U IO(0)
  1.  W !!?5,".....EXPORT CHS DATA",!!
  1.  I ACHSROUT<1 G NORECDS
  1.  ;ACHS*3.1*13 IHS/OIT/FCJ ADDED UFMS REC 8 TO NXT LINE
  1.  F ACHSY=2:1:7,8 S ACHSTYP(ACHSY)=$$REC^ACHSACO1(ACHSY)
  1.  D R1
  1.  I $$DIR^XBDIR("E","Enter <RETURN> to Continue")
  1.  I '$D(ACHSCRTN) S ACHSCRTN=""
  1.  I '$D(ACHSMDAT) S ACHSMDAT=DT
  1.  ;ITSC/SET/JVK ACHS*3.1*11 LOOK FOR VERSION AND PATCH
  1.  S (ACHSVDA,ACHSPA)=""
  1.  S ACHSVDA=$O(^DIC(9.4,"B","CONTRACT HEALTH MGMT SYSTEM",ACHSVDA))
  1.  S ACHSVER=$P(^DIC(9.4,ACHSVDA,"VERSION"),U)
  1.  S ACHSPA=$O(^DIC(9.4,ACHSVDA,22,"B",ACHSVER,ACHSPA))
  1.  ;S ACHSPA=$P(^DIC(9.4,119,22,3,"PAH",0),U,4)
  1.  ;S ACHSPA=$P(^DIC(9.4,ACHSVDA,22,ACHSPA,"PAH",0),U,4)  ;ACHS*3.1*23
  1.  S ACHSPA=$P(^DIC(9.4,ACHSVDA,22,ACHSPA,"PAH",0),U,4) S:ACHSPA>10 ACHSPA=11  ;ACHS
  1.  ;ITSC/SET/JVK ACHS*3.1*11 ADD VERSION OF CHS TO ZERO NODE
  1.  ;S ^ACHSDATA(0)=$P($G(^AUTTLOC(DUZ(2),0)),U,10)_U_$$LOC^ACHS_U_DT_U_ACHSFDT_U_ACHSLDAT_"^^"_ACHSRTYP_U_ACHSCRTN_U_ACHSMDAT_U_$P($G(^ACHS(9,DUZ(2),"FY",ACHSCFY,0)),U,2)_U_$P($G(^ACHS(9,DUZ(2),"FY",ACHSCFY,0)),U,3)
  1.  ;S ^ACHSDATA(0)=$P($G(^AUTTLOC(DUZ(2),0)),U,10)_U_$$LOC^ACHS_U_DT_U_ACHSFDT_U_ACHSLDAT_"^^"_ACHSRTYP_U_ACHSCRTN_U_ACHSMDAT_U_$P($G(^ACHS(9,DUZ(2),"FY",ACHSCFY,0)),U,2)_U_$P($G(^ACHS(9,DUZ(2),"FY",ACHSCFY,0)),U,3)_U_ACHSVER_"*"_ACHSPA
  1.  ;ACHS*3.1*23 CHG NXT LN TO TEST FOR ICD9 OR ICD10 FORMAT
  1.  I DT<$$PARM^ACHS(0,18) D SETR1
  1.  E  D SETR2
  1.  ; Set up Qed report.
  1.  I ACHSIO=IO G NOQUE
  1.  S ZTRTN="REPORT^ACHSTX8",ZTDTH=$H,ZTIO=ACHSION,ZTDESC="REPORT OF EXPORT RECORDS, for "_$P($G(^AUTTLOC(DUZ(2),0)),U,2)_"."
  1.  F %="ACHSFDT","ACHSRTYP","ACHSRTYP(","ACHSLDAT","ACHSTYP(" S ZTSAVE(%)=""
  1.  D ^%ZTLOAD
  1. NOQUE ; Report not q'd. 
  1.  I ACHSREEX D REPORT G WRITETP
  1.  ;I $D(ACHSPPO) D REPORT
  1.  S DIE="^ACHSTXST("
  1.  I '$D(^ACHSTXST("B",DUZ(2))) S $P(^ACHSTXST(0),U,3)=DUZ(2),^ACHSTXST(DUZ(2),0)=DUZ(2),$P(^ACHSTXST(0),U,4)=$P(^ACHSTXST(0),U,4)+1,^ACHSTXST("B",DUZ(2),DUZ(2))=""
  1.  S DA=DUZ(2),DR="1///"_DT,DR(2,9002070.01)=".01///"_DT
  1.  D ^DIE
  1.  S DA(1)=1
  1.  F ACHS=0:0 S ACHS=$O(^ACHSTXST(DUZ(2),1,ACHS)) Q:ACHS<1  S DA(1)=ACHS
  1.  S ^ACHSTXST(DUZ(2),1,DA(1),0)=DT_U_ACHSFDT_U_ACHSLDAT_"^^"_ACHSROUT_U_ACHSCRTN_U_ACHSMDAT_"^^^N"
  1.  D NUMRECS(DA(1)) ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
  1. WRITETP ; Save global for export. 
  1.  S XBGL="ACHSDATA",XBNAR="CONTRACT HEALTH export data",XBMED="F"
  1.  ;IHS/SET/JVK ACHS*3.1*6 FOR THOSE SITES SENDING DIRECT TO FI
  1.  I $$GET1^DIQ(9002079,DUZ(2),1412,"I")="N" S XBQTO=""
  1.  ;
  1.  S XBFN="ACHS"_$P($G(^AUTTLOC(DUZ(2),0)),U,10)     ;ACHS*3.1*19
  1.  D NOW^%DTC S XBFN=XBFN_"."_(%I(3)+1700)_$E(%,4,7)_"_"_$P(%,".",2)  ;ACHS*3.1*19
  1.  I $P(^AUTTSITE(1,0),U,14)'="",$D(^%ZIB(9888888.93,"B",$P(^AUTTSITE(1,0),U,14))) S XBS1=$P(^AUTTSITE(1,0),U,14) ;ACHS*3.1*25
  1.  D ^XBGSAVE    ;Saves and sends global
  1.  I XBFLG G JOBABEND
  1.  I 'ACHSREEX S $P(^ACHSTXST(DUZ(2),1,DA(1),0),U,10)="Y"
  1.  I $D(ACHSPPO) D REPORT
  1.  G ENTRETRN
  1.  ;
  1. JOBABEND ;EP.
  1.  W !!?10,"ABNORMAL END OF CHS EXPORT"
  1.  I $D(XBFLG),XBFLG W !!,XBFLG(1),! K XBFLG
  1.  G ENTRETRN
  1.  ;
  1. TXFEF ;EP.
  1.  W !!,"EXPORT PROGRAM ALREADY RUN THIS DATE FOR THIS FACILITY",*7
  1.  ;TPF;FOR CLEARING: EDIT 'CHS TX STATUS' FILE ENTER FACILITY NAME AND DELETE
  1. ENTRETRN ;
  1.  W !
  1.  I $$DIR^XBDIR("E","Press RETURN...")
  1. KILL ;EP - Kill vars, close device, quit.
  1.  I '$$LOCK^ACHS("^ACHSF(DUZ(2),""D"")","-")
  1.  K %DT,X1,XBDT,XBF,XBGL,XBTIT,ACHSCRTN,DA,DIC,DIE,DR,DUOUT,DX,DY
  1.  ;
  1.  ;for test !!!!! only delete vars if reexporting
  1.  I ACHSREEX D EN^XBVK("ACHS"),^%ZISC,^ACHSVAR Q
  1.  K ACHSTXTY,^TMP("ACHSTX",$J)
  1.  D ^%ZISC
  1.  Q
  1.  ;
  1. NORECDS ;EP
  1.  W !!,*7,?10,"NO RECORDS GENERATED FOR EXPORT",!!
  1.  G ENTRETRN
  1.  ;
  1. REPORT ;EP - From TaskMan.
  1.  U IO
  1.  D LINES^ACHSFU,NOW^ACHS
  1.  S ACHSTIME=$$C^XBFUNC(ACHSTIME,80),X=$$C^XBFUNC($$LOC^ACHS,80)
  1.  X:$D(ACHSPPO) ACHSPPO
  1.  W @IOF,!,ACHS("*"),!,"*",?25,"CONTRACT HEALTH MANAGEMENT SYSTEM",?78,"*",!,"*",?30,"EXPORTED RECORDS BY TYPE",?78,"*",!,"*",$E(X,2,80),?78,"*",!,"*",$E(ACHSTIME,2,80),?78,"*",!,ACHS("*"),!!!
  1.  D R1
  1.  W @IOF
  1.  X:$D(ACHSPPC) ACHSPPC
  1.  D ERPT^ACHS
  1.  Q
  1.  ;
  1. R1 ; Print basic info for the report.
  1.  W ?20,"BEGINNING ADD/UPD DATE",?45,"=",?50,$$FMTE^XLFDT(ACHSFDT),!!?20,"ENDING ADD/UPD DATE",?45,"=",?50,$$FMTE^XLFDT(ACHSLDAT),!!?15,$$REPEAT^XLFSTR("-",47),!?15,"T Y P E   O F   R E C O R D",?55,"NUMBER",!?15,$$REPEAT^XLFSTR("-",47),!!
  1.  S ACHSRTYP=0
  1.  ;ACHS*3.1*13 IHS/OIT/FCJ CHG 7 TO 8 TO NXT LINE
  1.  F ACHS=2:1:8 W ?10,ACHS,".",?15,ACHSTYP(ACHS),?55,$J(ACHSRTYP(ACHS),6),! S ACHSRTYP=ACHSRTYP+ACHSRTYP(ACHS)
  1.  W !?20,"TOTAL ALL TYPES",?55,$J(ACHSRTYP,6),!!
  1.  Q
  1.  ;
  1. CANOBJ ;EP - Set CAN, ObjClass, & SCC into ACHSCAN, ACHSOBJC, ACHSSCC.
  1.  S (ACHSCAN,ACHSSCC,ACHSOBJC)=""
  1.  S:$P(ACHSDOCR,U,6)'="" ACHSCAN=$P($G(^ACHS(2,$P(ACHSDOCR,U,6),0)),U)
  1.  S:$P(ACHSDOCR,U,7)'="" ACHSSCC=$P($G(^ACHS(3,DUZ(2),1,$P(ACHSDOCR,U,7),0)),U)
  1.  ;ACHS*3.1*14 2.28.2008 IHS/OIT/FCJ ADDED NXT LINE TO TEST FOR OCC IF NOT IN FILE USES SCC DEFAULT
  1.  I $P(ACHSDOCR,U,10)'="",$G(^ACHSOCC($P(ACHSDOCR,U,10),0))="" S ACHSOBJC=$P(ACHSDOCR,U,10) Q
  1.  S:$P(ACHSDOCR,U,10)'="" ACHSOBJC=$P($G(^ACHSOCC($P(ACHSDOCR,U,10),0)),U)
  1.  Q
  1.  ;
  1. IPA ;EP - Set IHS pay amt into ACHSIPA.
  1.  S X=$P(ACHSTRAN,U,4),X=$P(X,".")_$E($P(X,".",2)_"00",1,2),ACHSIPA=$E(X+1000000000000,2,13)
  1.  Q
  1.  ;
  1. TOS ;EP - Set document type into ACHSTOS2.
  1.  S X=$P(ACHSDOCR,U,4),ACHSTOS2=$S(X=1:43,X=2:57,X=3:64,1:"  ")
  1.  Q
  1.  ;
  1. TRIB ;EP - Set patient's tribe into ACHSTRIB.
  1.  S ACHSTRIB="999"
  1.  I $D(^AUPNPAT(DFN,11)),$P($G(^(11)),U,8),$D(^AUTTTRI($P(^(11),U,8),0)),$L($P(^(0),U,2))=3 S ACHSTRIB=$P(^(0),U,2)
  1.  Q
  1.  ; 
  1.  ;Begin New Code;IHS/SET/GTH ACHS*3.1*5 12/06/2002
  1. NUMRECS(DA) ;
  1.  NEW DIE,DR
  1.  S DA(1)=DUZ(2),DIE="^ACHSTXST("_DA(1)_",1,",DR=""
  1.  F %=11:1:17 S DR=DR_";"_%_"///"_$G(ACHSRTYP(%-10),"0")
  1.  S DR=$E(DR,2,99999)
  1.  S DR=DR_";18///"_ACHSRTYP(8)_";19///"_ACHSTXTY  ;ACHS*3.1*13 IHS/OIT/FCJ Rec type "U" and type of export
  1.  D ^DIE
  1.  ;End New Code;IHS/SET/GTH ACHS*3.1*5 12/06/2002
  1. TST ;ADD TRANSACTIONS TO CHS TX STATUS FILE
  1.  Q:'$D(^TMP("ACHSTX",$J))
  1.  S DA(2)=DUZ(2),DA(1)=DA
  1.  S (DIC,DIE)="^ACHSTXST("_DA(2)_",1,"_DA(1)_",2,"
  1.  S DIC("P")=$P(^DD(9002070.01,201,0),U,2),DIC(0)="L",DLAYGO=9002070,DIADD=1
  1.  S P=0 F  S P=$O(^TMP("ACHSTX",$J,P)) Q:P'?1N.N  D
  1.  .S T=0 F  S T=$O(^TMP("ACHSTX",$J,P,T)) Q:T'?1N.N  D
  1.  ..S X=P D ^DIC S DA=+Y
  1.  ..S DR=".02////"_T
  1.  ..D ^DIE
  1.  ;Update export date in Facility file
  1.  ;ACHS*3.1*14 11/1/2008 IHS/OIT/FCJ TEST FOR REEXPORT
  1.  I 'ACHSREEX S $P(^ACHSF(DUZ(2),0),U,14)=DT
  1.  Q
  1. SETR1 ;ICD-9 FORMAT;ACHS*3.1*23
  1.  S ^ACHSDATA(0)=$P($G(^AUTTLOC(DUZ(2),0)),U,10)_U_$$LOC^ACHS_U_DT_U_ACHSFDT_U_ACHSLDAT_"^^"_ACHSRTYP_U_ACHSCRTN_U_ACHSMDAT_U_$P($G(^ACHS(9,DUZ(2),"FY",ACHSCFY,0)),U,2)_U_$P($G(^ACHS(9,DUZ(2),"FY",ACHSCFY,0)),U,3)_U_ACHSVER_"*"_ACHSPA
  1.  Q
  1. SETR2 ;ICD-10 FORMAT;ACHS*3.1*23
  1.  S ^ACHSDATA(0)=$P($G(^AUTTLOC(DUZ(2),0)),U,10)_U_$$LOC^ACHS_U_DT_U_ACHSFDT_U_ACHSLDAT_"^^"_ACHSRTYP_U_ACHSCRTN_U_ACHSMDAT_U_$P($G(^ACHS(9,DUZ(2),"FY",ACHSCFY,0)),U,2)_U_$P($G(^ACHS(9,DUZ(2),"FY",ACHSCFY,0)),U,3)_U_"CRV003"
  1.  Q