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

ACHSTX3C.m

Go to the documentation of this file. 
  1. ACHSTX3C ; IHS/ITSC/PMF - EXPORT DATA (4A/9) - RECORD 3(PATIENT FOR AO/FI) ;
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**13,18,22,27**;JUN 11, 2001;Build 43
  1.  ;ACHS*3.1*13 11/27/06 IHS/OIT/FCJ PRT POL & COV TYPE FR CORRECT FILE
  1.  ;ACHS*3.1*22 9/9/13 IHS.OIT.FCJ FIXED CENTURY DATE
  1.  ;
  1. MCR ;
  1.  N ACHSMBI,ACHSMBIS   ;ACHS*3.1*27
  1.  G MCD:'$D(^AUPNMCR(ACHSR,0))
  1.  S ACHSINSR=$P(^AUPNMCR(ACHSR,0),U,2)
  1.  F ACHS=0:0 S ACHS=$O(^AUPNMCR(ACHSR,11,ACHS)) G MCD:'ACHS D INIT3C,MCR1
  1. MCR1 ;
  1.  S ACHSMBI=0,ACHSMBIS=0,ACHSMBI=$$GETMBI^AUPNMBI(DFN,DT,0)                 ;ACHS*3.1*27 check for new MBI
  1.  S:+ACHSMBI<1 ACHSMBI=$P(^AUPNMCR(ACHSR,0),U,3),ACHSMBIS=1                  ;ACHS*3.1*27
  1.  ;D SET3C(33,47,$E($P(^AUPNMCR(ACHSR,0),U,3)_$J("",15),1,15))    ;ACHS*3.1*27
  1.  S:$P(^AUPNMCR(ACHSR,11,ACHS,0),U,3) ACHSMBI=$P(^(0),U,6)        ;ACHS*3.1*27 check for coverage type "D"
  1.  D SET3C(33,47,$E(ACHSMBI_$J("",15),1,15))                       ;ACHS*3.1*27 
  1.  I ACHSMBIS>0,$P(^AUPNMCR(ACHSR,0),U,4)]"",$D(^AUTTMCS($P(^AUPNMCR(ACHSR,0),U,4),0)) D SET3C(50,51,$E($P(^(0),U)_"  ",1,2))
  1.  D  ;IV&V DATE CHANGE (ADD CC & CC TO END OF 3C RECORD)
  1.  . N ACHSTDT ;TEMPORARY DATE VARIABLE
  1.  . S ACHSTDT=17000000+$P(^AUPNMCR(ACHSR,11,ACHS,0),U)
  1.  . D SET3C(52,57,$E(ACHSTDT,3,8))
  1.  . D SET3C(77,78,$E(ACHSTDT,1,2))
  1.  . S ACHSTDT=17000000+$P(^AUPNMCR(ACHSR,11,ACHS,0),U,2)
  1.  . D SET3C(58,63,$E(ACHSTDT,3,8))
  1.  . D SET3C(79,80,$E(ACHSTDT,1,2))
  1.  ;FCJ;CHANGE 16 TO 13 IN NXT LINE
  1.  ;D SET3C(64,76,$E($P(^AUPNMCR(ACHSR,11,ACHS,0),U,3)_$J("",16),1,16)) ;IV&V DATE FIX (SHORTEN COVERAGE TYPE FIELD)
  1.  D SET3C(64,76,$E($P(^AUPNMCR(ACHSR,11,ACHS,0),U,3)_$J("",13),1,13))
  1.  S:'$D(ACHS3CFL) ACHSRCT=ACHSRCT+1,^ACHSDATA(ACHSRCT)=ACHS3C,ACHSRTYP(3)=ACHSRTYP(3)+1
  1.  ;
  1.  I '$D(ACHS3CFL) S PMFF=^ACHSDATA(ACHSRCT) D ^ACHSTX99
  1.  ;
  1.  S:$D(ACHS3CFL) ACHS3CFL=ACHS3CFL+1,ACHS3C(ACHS3CFL)=ACHS3C
  1.  Q
  1.  ;
  1. MCD ;
  1.  G RRE:'$D(^AUPNMCD("AB",ACHSR))
  1.  S ACHSST=0
  1. MCDA ;
  1.  S ACHSST=$O(^AUPNMCD("AB",ACHSR,ACHSST))
  1.  G RRE:'ACHSST
  1.  S ACHSMCD=""
  1. MCDB ;
  1.  S ACHSMCD=$O(^AUPNMCD("AB",ACHSR,ACHSST,ACHSMCD))
  1.  G MCDA:ACHSMCD=""
  1.  S DA=0
  1.  D MCD1
  1.  G MCDB
  1.  ;
  1. MCD1 ;
  1.  S DA=$O(^AUPNMCD("AB",ACHSR,ACHSST,ACHSMCD,DA))
  1.  Q:+DA=0
  1.  G MCD1:'$D(^AUPNMCD(DA,0))
  1.  S ACHSINSR=$P(^AUPNMCD(DA,0),U,2)
  1.  D INIT3C,MCD2
  1.  G MCD1
  1.  ;
  1. MCD2 ;
  1.  D SET3C(33,47,$E($P(^AUPNMCD(DA,0),U,3)_$J("",15),1,15))
  1.  D SET3C(48,49,$P(^DIC(5,ACHSST,0),U,2))
  1.  F ACHS=0:0 S ACHS=$O(^AUPNMCD(DA,11,ACHS)) Q:'ACHS  D MCD3
  1.  Q
  1.  ;
  1. MCD3 ;
  1.  ;ACHS*3.1*22 IHS.OIT.FCJ MODIFIED NXT SECTION TO INCLUDE CENTURY IN POSITION 77-80
  1.  ;D SET3C(52,57,$E($E($P(^AUPNMCD(DA,11,ACHS,0),U),2,7)_$J("",6),1,6))
  1.  ;D SET3C(58,63,$E($E($P(^AUPNMCD(DA,11,ACHS,0),U,2),2,7)_$J("",6),1,6))
  1.  ;D SET3C(64,79,$E($P(^AUPNMCD(DA,11,ACHS,0),U,3)_$J("",16),1,16))
  1.  S ACHSTDT=17000000+$P(^AUPNMCD(DA,11,ACHS,0),U)
  1.  D ELGB
  1.  S ACHSTDT=17000000+$P(^AUPNMCD(DA,11,ACHS,0),U,2)
  1.  D ELGE
  1.  D SET3C(64,76,$E($P(^AUPNMCD(DA,11,ACHS,0),U,3)_$J("",13),1,13))
  1.  S:'$D(ACHS3CFL) ACHSRCT=ACHSRCT+1,^ACHSDATA(ACHSRCT)=ACHS3C,ACHSRTYP(3)=ACHSRTYP(3)+1
  1.  ;
  1.  I '$D(ACHS3CFL) S PMFF=^ACHSDATA(ACHSRCT) D ^ACHSTX99
  1.  ;
  1.  S:$D(ACHS3CFL) ACHS3CFL=ACHS3CFL+1,ACHS3C(ACHS3CFL)=ACHS3C
  1.  Q
  1.  ;
  1. RRE ;
  1.  N ACHSMBI,ACHSMBIS   ;ACHS*3.1*27
  1.  G PRI:'$D(^AUPNRRE(ACHSR,0))
  1.  S ACHSINSR=$P(^AUPNRRE(ACHSR,0),U,2)
  1.  F ACHS=0:0 S ACHS=$O(^AUPNRRE(ACHSR,11,ACHS)) G PRI:'ACHS D INIT3C,RRE1
  1. RRE1 ;
  1.  S ACHSMBI=0,ACHSMBIS=0,ACHSMBI=$$GETMBI^AUPNMBI(DFN,DT,0)                 ;ACHS*3.1*27 check for new MBI
  1.  S:+ACHSMBI<1 ACHSMBI=$P(^AUPNRRE(ACHSR,0),U,4),ACHSMBIS=1                  ;ACHS*3.1*27
  1.  ;D SET3C(33,47,$E($P(^AUPNRRE(ACHSR,0),U,4)_$J("",15),1,15))    ;ACHS*3.1*27
  1.  D SET3C(33,47,$E(ACHSMBI_$J("",15),1,15))                       ;ACHS*3.1*27 
  1.  ;I $P(^AUPNRRE(ACHSR,0),U,3)]"",$D(^AUTTRRP($P(^AUPNRRE(ACHSR,0),U,3),0)) D SET3C(50,51,$E($P(^(0),U)_"  ",1,2))
  1.  I ACHSMBIS>0,$P(^AUPNRRE(ACHSR,0),U,3)]"",$D(^AUTTRRP($P(^AUPNRRE(ACHSR,0),U,3),0)) D SET3C(50,51,$E($P(^(0),U)_"  ",1,2))
  1.  ;ACHS*3.1*22 IHS.OIT.FCJ MODIFIED NXT SECTION TO INCLUDE CENTURY IN POSITION 77-80
  1.  ;D SET3C(52,57,$E($E($P(^AUPNRRE(ACHSR,11,ACHS,0),U),2,7)_$J("",6),1,6))
  1.  ;D SET3C(58,63,$E($E($P(^AUPNRRE(ACHSR,11,ACHS,0),U,2),2,7)_$J("",6),1,6))
  1.  ;D SET3C(64,79,$E($P(^AUPNRRE(ACHSR,11,ACHS,0),U,3)_$J("",16),1,16))
  1.  S ACHSTDT=17000000+$P(^AUPNRRE(ACHSR,11,ACHS,0),U)
  1.  D ELGB
  1.  S ACHSTDT=17000000+$P(^AUPNRRE(ACHSR,11,ACHS,0),U,2)
  1.  D ELGE
  1.  D SET3C(64,76,$E($P(^AUPNRRE(ACHSR,11,ACHS,0),U,3)_$J("",13),1,13))
  1.  S:'$D(ACHS3CFL) ACHSRCT=ACHSRCT+1,^ACHSDATA(ACHSRCT)=ACHS3C,ACHSRTYP(3)=ACHSRTYP(3)+1
  1.  I '$D(ACHS3CFL) S PMFF=^ACHSDATA(ACHSRCT) D ^ACHSTX99
  1.  ;
  1.  S:$D(ACHS3CFL) ACHS3CFL=ACHS3CFL+1,ACHS3C(ACHS3CFL)=ACHS3C
  1.  Q
  1.  ;
  1. PRI ;
  1.  G END:'$D(^AUPNPRVT(ACHSR,0))
  1.  S ACHS=0
  1. PRIA ;
  1.  S ACHS=$O(^AUPNPRVT(ACHSR,11,ACHS))
  1.  G END:+ACHS=0
  1.  S ACHSINSR=$P(^AUPNPRVT(ACHSR,11,ACHS,0),U)
  1.  D INIT3C
  1. PRI1 ;
  1.  ;ACHS*3.1*13 11/27/06 IHS/OIT/FCJ PRT POLICY # FR CORRECT FILE
  1.  ;D SET3C(33,47,$E($P(^AUPNPRVT(ACHSR,11,ACHS,0),U,2)_$J("",15),1,15))
  1.  I $P(ACHSINSR,U,8),$D(^AUPN3PPH($P(ACHSINSR,U,8),0)) D
  1.  .D SET3C(33,47,$E($P(^AUPN3PPH($P(ACHSINSR,U,8),0),U,4)_$J("",15),1,15))
  1.  ;ACHS*3.1*22 IHS.OIT.FCJ MODIFIED NXT SECTION TO INCLUDE CENTURY IN POSITION 77-80
  1.  ;D SET3C(52,57,$E($E($P(^AUPNPRVT(ACHSR,11,ACHS,0),U,6),2,7)_$J("",6),1,6))
  1.  ;D SET3C(58,63,$E($E($P(^AUPNPRVT(ACHSR,11,ACHS,0),U,7),2,7)_$J("",6),1,6))
  1.  S ACHSTDT=17000000+$P(^AUPNPRVT(ACHSR,11,ACHS,0),U,6)
  1.  D ELGB
  1.  S ACHSTDT=17000000+$P(^AUPNPRVT(ACHSR,11,ACHS,0),U,7)
  1.  D ELGE
  1.  ;
  1.  ;ACHS*3.1*13 11/27/06 IHS/OIT/FCJ PRT COV TYPE FR CORRECT FILE
  1.  ;G:'$P(^AUPNPRVT(ACHSR,11,ACHS,0),U,3) PRIZ
  1.  ;S X=$P(^AUPNPRVT(ACHSR,11,ACHS,0),U,3)
  1.  ;G PRIZ:X=""
  1.  ;I '$D(^AUTTPIC(X,0)) G PRIZ
  1.  I $P(ACHSINSR,U,8),$D(^AUPN3PPH($P(ACHSINSR,U,8),0)) D
  1.  .S X=$P(^AUPN3PPH($P(ACHSPINS,U,8),0),U,5)
  1.  .Q:'$D(^AUTTPIC(X,0))
  1.  .S Y=$G(^AUTTPIC(X,0)),Y=$E($P(Y,U,1),1,10)_$E($P(Y,U,3),1,5)
  1.  .;D SET3C(64,79,$E(Y_$J("",16),1,16))  ;ACHS*3.1*22
  1.  .D SET3C(64,76,$E(Y_$J("",13),1,13))   ;ACHS*3.1*22
  1.  ;ACHS*3.1*13 11/27/06 IHS/OIT/FCJ END OF CHANGES
  1. PRIZ ;
  1.  ;ACHS*3.1*18 3-10-2010 IHS.OIT.FCJ FIXED THE ACHSRTYP IN LINE BELOW
  1.  ;S:'$D(ACHS3CFL) ACHSRCT=ACHSRCT+1,^ACHSDATA(ACHSRCT)=ACHS3C,ACHSTRYP(3)=ACHSRTYP(3)+1
  1.  S:'$D(ACHS3CFL) ACHSRCT=ACHSRCT+1,^ACHSDATA(ACHSRCT)=ACHS3C,ACHSRTYP(3)=ACHSRTYP(3)+1
  1.  ;
  1.  I '$D(ACHS3CFL) S PMFF=^ACHSDATA(ACHSRCT) D ^ACHSTX99
  1.  ;
  1.  S:$D(ACHS3CFL) ACHS3CFL=ACHS3CFL+1,ACHS3C(ACHS3CFL)=ACHS3C
  1.  G PRIA
  1.  ;
  1. END ;
  1.  Q
  1.  ;
  1. ELGB ;SET BEG ELIG DT;ACHS*3.1*22
  1.  D SET3C(52,57,$E(ACHSTDT,3,8))
  1.  D SET3C(77,78,$E(ACHSTDT,1,2))
  1.  Q
  1. ELGE ;SET END ELIG DT;ACHS*3.1*22
  1.  D SET3C(58,63,$E(ACHSTDT,3,8))
  1.  D SET3C(79,80,$E(ACHSTDT,1,2))
  1.  Q
  1. INIT3C ;
  1.  ;S ACHS3C="3C"_$E($P(^AUTNINS(ACHSINSR,0),U)_$J("",30),1,30),ACHS3C=$E(ACHS3C_$J("",79),1,79)_ACHSDEST    ;ACHS*3.1*22
  1.  S ACHS3C="3C"_$E($P(^AUTNINS(ACHSINSR,0),U)_$J("",30),1,30),ACHS3C=$E(ACHS3C_$J("",80),1,80)     ;ACHS*3.1*22
  1.  Q
  1.  ;
  1. SET3C(B,E,V) ;
  1.  S ACHS3C=$E(ACHS3C,1,B-1)_V_$E(ACHS3C,E+1,80)
  1.  Q
  1.  ;