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

ACHSPCC3.m

Go to the documentation of this file. 
  1. ACHSPCC3 ; IHS/ITSC/PMF - CHS AREA SPLITOUT (3/5)(WRITE TO FLATFILES) ;
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**11,13,19,21,23**;JUN 11,2001;Build 43
  1.  ;ACHS*3.1*3  add UID to NPRS data
  1.  ;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - Reinstate display filename.
  1.  ;ITSC/SET/JVK ACHS*3.1*11 ADDED ADDITONAL RECORRDS FOR STAT PURPOSES
  1.  ;ACHS*3.1*13 IHS/OIT/FCJ ADDED UFMS PROCESSING
  1.  S (ACHSFLG,ACHSGCTR)=0
  1.  G PCC4
  1.  ;
  1. START ;
  1.  ;I ACHSGLBL="^ACHSBCBS",($$AOP^ACHS(2,8)=""!($$AOP^ACHS(2,8)="N")) G PCC4
  1.  I ACHSGCTR=1,ACHSCT2=0 G PCC4
  1.  S X=$O(@(ACHSGLBL_"(0)"))
  1.  I +X<1 G PCC4
  1.  I +X="**" G PCC4
  1. MSM ;
  1.  U IO(0)
  1.  W !!,"Processing the ",ACHSGLBL," (",ACHSDESC,") transaction file."
  1.  S ACHSMED="F"
  1.  D UNIX:"Ff"[ACHSMED
  1.  I $D(ACHSJFLG) D JOBABEND^ACHSPCC4 Q
  1. PCC4 ;
  1.  I ACHSFLG D JOBABEND^ACHSPCC4 Q
  1.  S ACHSGCTR=ACHSGCTR+1,ACHSGLBL=$P($T(@"GLOBS"+ACHSGCTR),";",3),ACHSDESC=$P($T(@"GLOBS"+ACHSGCTR),";",4),ACHSSUF=$P($T(@"GLOBS"+ACHSGCTR),";",5)
  1.  I ACHSGLBL="^ACHSUFMS" D UFMS G PCC4   ;ACHS*3.1*13 IHS/OIT/FCJ
  1.  I ACHSGLBL']"" D END^ACHSPCC4 Q
  1.  ;I ACHSGLBL
  1.  I ACHSGLBL="^ACHSBCBS",$$AOP^ACHS(2,8)="Y" G START
  1.  ;ITSC/SET/JVK ACHS*3.1*11;ACHS*3.1*23
  1.  ;I ACHSGLBL="^ACHSPIG" S ACHSSUF=ACHSSUF_$E($P(^AUTTLOC(DUZ(2),0),U,10),1,2)_"0000"
  1.  I (ACHSGLBL="^ACHSPIG")!(ACHSGLBL="^ACHSPG2") S ACHSSUF=ACHSSUF_$E($P(^AUTTLOC(DUZ(2),0),U,10),1,2)_"0000"
  1.  G PCC4:'$O(@(ACHSGLBL_"(0)"))
  1.  G START
  1.  ;
  1. UNIX ;
  1.  S ACHSFAC=$P(^AUTTLOC(DUZ(2),0),U,10)
  1.  ;S ACHSCCTR="PCC"
  1.  S ACHSHDNM=ACHSSUF
  1.  I ACHSHDNM="DHR" S ACHSHDNM="DHRP"
  1.  I ACHSGLBL="^ACHSCORE" S ACHSHDNM="DHRC"
  1.  S ACHSPGNM="ACHS",ACHSZIN=1
  1.  D FILESEL^ACHSEXUT
  1.  I $D(ACHSJFLG) G END
  1.  S ACHSZFN=ACHSEXFN,ACHSZIN=0
  1.  ;ACHS*3.1*21 CHANGED FILE NAME TO ALLOW MORE THEN 1 EXPORT A DAY...
  1.  S X=$E(DT,4,7)_$E(DT,2,3)
  1.  D NOW^%DTC S X=(%I(3)+1700)_$E(%,4,7)_"_"_$P(%,".",2)
  1.  S $P(ACHSZFN,".",2)=X
  1.  D OPENHFS^ACHSTCK1
  1.  I ACHSZZA D ERROR^ACHSTCK1 D JOBABEND^ACHSPCC4 Q
  1.  I ACHSGCTR=1 S ACHSDHRN=ACHSZFN
  1.  S IO=ACHSZDEV
  1.  U IO(0)
  1.  ;W !,"Please Standby - Copying Data to File: " ;,!?10,ACHSEXFS;IHS/SET/GTH ACHS*3.1*5 12/06/2002
  1.  W !,"Please Standby - Copying Data to File: ",!?10,ACHSZFN ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
  1.  D AZGSAV1M
  1. CLOSE ;EP
  1.  D ^%ZISC
  1.  U IO(0)
  1.  W !!?10,ACHSTXRC," Total Records Copied to Output Media",!
  1.  D RTRN^ACHS,TXLOGADD^ACHSTXUT
  1.  I ACHSY>0 G NORMEND
  1.  U IO(0)
  1.  W !,*7,?5,"UNABLE TO POST ENTRY TO IHS DATA TRANSMISSION LOG - NOTIFY SUPERVISOR"  ;ACHS*3.1*21 ADDED LINE FEED
  1.  S ACHSFLG=1
  1.  G END
  1.  ;
  1. NORMEND ;
  1.  I $D(^AFSTXLOG(0)) D
  1.  . S $P(^AFSTXLOG(DUZ(2),1,ACHSY,0),U,3)=$$HTFM^XLFDT($H)
  1.  . S $P(^AFSTXLOG(DUZ(2),1,ACHSY,0),U,4)="Y"
  1.  . S:$D(ACHSTXRC) $P(^AFSTXLOG(DUZ(2),1,ACHSY,0),U,2)=ACHSTXRC
  1.  . N DA,DIK
  1.  . S DIK="^AFSTXLOG("_DUZ(2)_",1,",DA(1)=DUZ(2),DA=ACHSY
  1.  . D IX^DIK
  1.  .Q
  1.  ;
  1. END ; Kill vars, post 1166 open doc, quit.
  1.  K ACHS,ACHS7A,ACHSFAC,ACHSMSG,ACHSRCTR,ACHSRR,ACHSRRCT,X1,X2
  1.  Q:$D(ACHSJFLG)
  1.  Q:'$L($T(FRD^AFSLODF0))
  1.  Q:$$AOP^ACHS(2,12)'="Y"
  1.  Q:$G(ACHSZFN)'["chsdh"
  1.  ; Post 1166 open document file.
  1.  W !,"Begin Posting DHR file to 1166 Open Document File..."
  1.  S AFSXPFN=ACHSDHRN
  1.  D FRD^AFSLODF0
  1.  K AFSXPFN
  1.  W !,"End Posting DHR file to 1166 Open Document File..."
  1.  Q
  1.  ;
  1. AZGSAV1M ;
  1.  U IO(0)
  1.  D WAIT^DICD
  1.  S DX=$X,DY=$Y,R="0",(ACHSRCTR,ACHSRR,ACHSRRR,ACHSRRCT,ACHSRRRC,ACHSTXRC)=0
  1.  S:ACHSGCTR=1 DY=DY+1
  1.  W !
  1. AZGSHJCL ;
  1.  ;ACHS*3.1*23 ADDED SECOND STAT FILE FOR ICD-10
  1.  ;D PCCHJCL^ACHSPCC4:ACHSGCTR=1,DPSHJCL^ACHSPCC4:ACHSGCTR=5,FIHJCL^ACHSPCC4:ACHSGCTR=2
  1.  D PCCHJCL^ACHSPCC4:ACHSGCTR=1,DPSHJCL^ACHSPCC4:(ACHSGCTR=5)!(ACHSGCTR=8),FIHJCL^ACHSPCC4:ACHSGCTR=2
  1. AZGS1 ;
  1.  S ACHSREF=ACHSGLBL_"("""_R_""")",R=$O(@ACHSREF) G AZGSTJCL:+R<1 S ACHSRCTR=+R I $D(^(R))<2 S X=^(R) D PADWRITE G AZGS1
  1.  S ACHSRR=0
  1. AZGS2 ;
  1.  S ACHSREF=ACHSGLBL_"("""_R_""","_ACHSRR_")",ACHSRR=$O(@ACHSREF) G AZGS1:+ACHSRR<1 I $D(^(ACHSRR))<2 S X=^(ACHSRR),ACHSRRCT=ACHSRR D PADWRITE G AZGS2
  1.  S ACHSRRR=0
  1. AZGS3 ;
  1.  S ACHSREF=ACHSGLBL_"("""_R_""","""_ACHSRR_""","_ACHSRRR_")",ACHSRRR=$O(@ACHSREF) G AZGS2:+ACHSRRR<1 S X=^(ACHSRRR),ACHSRRCT=ACHSRRR
  1.  D PADWRITE
  1.  G AZGS3
  1.  ;
  1. AZGSTJCL ;
  1.  ;ACHS*3.1*23
  1.  ;D PCCTJCL^ACHSPCC4:ACHSGCTR=1,DPSTJCL^ACHSPCC4:ACHSGCTR=5
  1.  D PCCTJCL^ACHSPCC4:ACHSGCTR=1,DPSTJCL^ACHSPCC4:(ACHSGCTR=5)!(ACHSGCTR=8)
  1.  I ACHSGCTR=2 D PCCTJCL^ACHSPCC4,FITJCL^ACHSPCC4
  1.  ;U IO(0) W $J($S(ACHSRRCT>0:ACHSRRCT,1:RCTR),8)
  1.  Q
  1.  ;
  1. PADWRITE ;EP.
  1.  S:$L(X)<80 X=X_$J("",80-$L(X))
  1.  I $E(X,1,2)="7A" S ACHS7A=+$E(X,3,4),X=$S(ACHS7A=19:"HC",ACHS7A=20:"CO",1:"DO")_$E(X,3,80)
  1.  I $E(X,1,2)="7B" S X=$S(ACHS7A=19:"H2",ACHS7A=20:"C2",1:"D2")_$E(X,3,80)
  1.  ;JVK/ITSC/9.1.04
  1.  ;I $E(X,1,2)="7C" S X="D3"_$E(X,3,80)
  1.  I $E(X,1,2)="7C" S X=$S(ACHS7A=19:"H3",ACHS7A=20:"C3",1:"D3")_$E(X,3,80)
  1.  ;
  1.  ;2/1/2  pmf  add universal reg ID record
  1.  ;I $E(X,1,2)="7D" S X=$S(ACHS7A=19:"H3",ACHS7A=20:"C3",1:"D4")_$E(X,3,80)  ; ACHS*3.1*3
  1.  I $E(X,1,2)="7D" S X=$S(ACHS7A=19:"H4",ACHS7A=20:"C4",1:"D4")_$E(X,3,80)  ; ACHS*3.1*3
  1.  ;
  1.  I $E(X,1,2)="7E" S X=$S(ACHS7A=19:"H5",ACHS7A=20:"C5",1:"D5")_$E(X,3,80)  ; ACHS*3.1*11
  1.  I $E(X,1,2)="7F" S X=$S(ACHS7A=19:"H6",ACHS7A=20:"C6",1:"D6")_$E(X,3,80)  ; ACHS*3.1*11
  1.  I $E(X,1,2)="7G" S X=$S(ACHS7A=19:"H7",ACHS7A=20:"C7",1:"D7")_$E(X,3,80)  ; ACHS*3.1*11
  1.  I $E(X,1,2)="7H" S X=$S(ACHS7A=19:"H8",ACHS7A=20:"C8",1:"D8")_$E(X,3,80)  ; ACHS*3.1*11
  1.  I $E(X,1,2)="7I" S X=$S(ACHS7A=19:"H9",ACHS7A=20:"C9",1:"D9")_$E(X,3,80)  ; ACHS*3.1*11
  1.  I $E(X,1,2)="7J" S X=$S(ACHS7A=19:"H0",ACHS7A=20:"C0",1:"D0")_$E(X,3,80)  ; ACHS*3.1*11
  1.  I $E(X,1,2)="7K" S X=$S(ACHS7A=19:"HA",ACHS7A=20:"C1",1:"D1")_$E(X,3,80)  ; ACHS*3.1*11
  1.  I $E(X,1,2)="7L" S X=$S(ACHS7A=19:"HB",ACHS7A=20:"C2",1:"D2")_$E(X,3,80)  ; ACHS*3.1*11
  1.  I $E(X,1,2)="7M" S X=$S(ACHS7A=19:"HD",ACHS7A=20:"C3",1:"D3")_$E(X,3,80)  ; ACHS*3.1*11
  1.  ;I $E(X,1,2)="7N" S X=$S(ACHS7A=19:"HF",ACHS7A=20:"C4",1:"D4")_$E(X,3,80)  ; ACHS*3.1*11
  1.  I $E(X,1,2)="7X" S X=$S(ACHS7A=19:"HX",ACHS7A=20:"CX",1:"DX")_$E(X,3,80)  ; ACHS*3.1*3
  1.  ;
  1.  U IO
  1.  W X,!
  1.  ;
  1.  ;2/1/02  pmf  we no longer will write empty H3, C3 or D4 records
  1.  ;I $E(X,1,2)="H2" S X="H3" G PADWRITE  ; ACHS*3.1*3
  1.  ;I $E(X,1,2)="C2" S X="C3" G PADWRITE  ; ACHS*3.1*3
  1.  ;I $E(X,1,2)="D3" S X="D4" G PADWRITE  ; ACHS*3.1*3
  1.  ;
  1.  S ACHSTXRC=ACHSTXRC+1
  1.  I ACHSTXRC#100=0 U IO(0) W $J(ACHSTXRC,8)
  1.  Q:(ACHSGCTR>1)!($E(X)'="2")
  1.  ; Make entry into Area PO transaction file, as a DHR.
  1.  D ADD^ACHSAOPO($E(X,16,25),"DHR",X)
  1.  Q
  1.  ;
  1. UFMS ;SAVE AND SEND FILE;  ACHS*3.1*13 IHS/OIT/FCJ ADDED UFMS SECTION
  1.  S ACHSTXRC=+$E(^ACHSUFMS("COUNT"),15,18) Q:ACHSTXRC=0
  1.  U IO(0)
  1.  W !!,"Processing the ",ACHSGLBL," (",ACHSDESC,") transaction file."
  1.  S X=$E(DT,4,7)_$E(DT,2,3)
  1.  D NOW^%DTC S X=(%I(3)+1700)_$E(%,4,7)_"_"_$P(%,".",2)
  1.  S:$L(X)'=15 X=X_0
  1.  S X1=$P(^AUTTAREA($P(^AUTTLOC(DUZ(2),0),U,4),0),U,3)
  1.  S:X1="S" X1="X"  ;ACHS*3.1*19
  1.  S XBFN="IHS_PO_CHSMIS_"_X1_"_"_X_".dat"
  1.  S ACHSEXFS="IHSPOCHSMIS"_X1_X_".dat",ACHSEXFS=$TR(ACHSEXFS,"_","")
  1.  S XBGL="ACHSUFMS",XBNAR="CONTRACT HEALTH UFMS export data",XBMED="F",XBFLT=1
  1.  S XBS1="ACHS UFMS B",XBQ="N"
  1.  ;ACHS*3.1*21 CHANGED SETTING XBUF TO I ELSE AND ADDED TEST FOR OS
  1.  I $$AOP^ACHS(3,2)'="" S XBUF=$$AOP^ACHS(3,2)
  1.  E  S XBUF=$S($$OS^ACHS=2:"c:\usr\spool\chsdata",1:"/usr/spool/chsdata")
  1.  D ^XBGSAVE    ;Saves and sends global
  1.  D CLOSE
  1.  Q
  1.  ;
  1.  ;ITSC/SET/JVK ACHS*3.1*11 changed name of 638 export to chsstat
  1.  ;OIT.IHS.FCJ ACHS*3.1*23 ADDED NEW STAT REC FOR ICD-10
  1. GLOBS ;;ACHSGLBL;ACHSDESC;ACHSSUF
  1.  ;;^ACHSPCC;DHR;DHR
  1.  ;;^ACHSBCBS;BLUE CROSS/SHIELD;bcs
  1.  ;;^ACHSAOVU;VENDOR RECORDS;aov
  1.  ;;^ACHSAOPD;PAYMENT RECORDS;aop
  1.  ;;^ACHSPIG;638 STATISTICAL DATA;stat;638  ; ACHS*3.1*11
  1.  ;;^ACHSCORE;DHR for CORE;DHR
  1.  ;;^ACHSUFMS;DHR records for UFMS;IHS    ;ACHS*3.1*13 IHS/OIT/FCJ
  1.  ;;^ACHSPG2;638 STATISTICAL DATA;stat;638  ; ACHS*3.1*23