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