ACHSRPFU ; IHS/OIT/FCJ - PRINT CHS FORM AND DATA 3 OF 3;JUL 10, 2008 ; 30 Jun 2011 10:10 AM
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**18,19,20**;JUN 11,2001
;ACHS*3.1*18 4.29.2010 IHS.OIT.FCJ NEW ROUTINE
;SET VARIABLES IN TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN
;CALLED BY ACHSRPF1
;
INS ;
S ACHSIPRM="N" ;SET PRIMARY INS FLAG TO NO
D FORMAT ;GET INS INF
D SB1^ACHSRPF
S N="" ;INITIALIZE INS SUBSCRIPT
;
PONUM ; -- Field 1 : DCR #, Document type, PDO number.
;
S ACHSDOFY=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,27)
S ACHSCTYP=$S($P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,2)),U,9)'="":$P(^ACHSF(DUZ(2),"D",ACHSDIEN,2),U,9),1:"")
I $D(ACHSCTYP),ACHSCTYP'="" S ACHSCTYP=$P(^ACHSCTYP(ACHSCTYP,0),U,2)
S ACHSDHHS="HHSI"_$P($G(^ACHSF(DUZ(2),0)),U,11)_ACHSDOFY_$E(ACHSORDN,3,5)_$E(ACHSORDN,7,11)_ACHSCTYP
S ACHS3TY="" I $$PARM^ACHS(2,20)="Y" S ACHS3TY=$S(ACHSTYPV=1:323,ACHSTYPV=2:324,1:325) ;ACHS*3.1*19
S ACHSPO=$E($P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,27),3)_ACHSORDN
;ACHS*3.1*19 MODIFIED DCR IN NEXT LINE
I $$PARM^ACHS(2,18)="N" D S ACHSDCR=""
S ^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,0)=ACHSPO_U_ACHSDHHS_U_ACHSTYPE_U_ACHSDCR_U_ACHS3TY_U_ACHSSF_U_$S($D(ACHSBLKF):1,1:"")_U_E(11)_U_ACHSTYPV
;
ORDFAC ;
;$G(B(1)) ORDERING FACILITY NAME
;$G(B(4)) ORDERING FACILITY NUMBER
;$G(B(2)) ORDERING FACILITY ADDRESS
;$G(B(3)) ORDERING FACILITY ADDRESS
S ^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,0)=^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,0)_U_$G(B(1))_U_$G(B(4))_U_$G(B(2))_U_$G(B(3))
;
PAT ;Pat Ident-Box 2
;A(2)-PATIENT NAME
;A(3)-PATIENT CITY, STATE, ZIP
;A(11)-SSN
;V=VERIFIED BY SSA;A=SSN ADDED BY SSA;N=FAC SSN NOT = TO SSA SSN;D=SSN MATCHES SSA-DATA DIFFERS;P=PEND VER;X=SSA COULD NOT VERIFY/SUPPLY SSN
S ACHSSNS="" I $G(DFN) S ACHSSSNS=$$SSV^ACHSTX3(DFN) I "PVX"[ACHSSSNS S $P(^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,1),U,3)=ACHSSNS
S ^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,1)=$G(A(2))_U_$G(A(3))_U_$G(A(11))_U_ACHSSNS
I $D(ACHSBLKF) S $P(^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,1),U)="** BLANKET **"
PATO ; OTHER INFO
;A(1)-FACHRN
;A(4)-A(5) AGE SEX COMCODE
;A(7)-DESCRIPTION
S ^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,1)=^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,1)_U_$E($G(A(1)),1,27)_U_$G(A(4))_" "_$G(A(5))_U_"Desc: "_$G(A(7))
;
INSPRM ;Primary INS INFO
;Field 3.a. : Name of Policy Holder.
I ACHSIPRM="Y" D
.S N=$O(I("P",N))
.S ACHSIPRM=N
.S $P(^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,"I"),U)=$E(I(N,1),1,22)
I N'="" D
.;I(N,2)-Field 3.b. : Plan Name.
.;I(N,3)-Field 3.c. : Insurer's address.
.;I(N,4)-Insurer's addrs, cont.
.;I(N,5)-Field 3.d. : Insurer's Policy Number.
.;I(N,6)-Field 3.e. : Insurer's Coverage Type.
.;I(N,7)-Field 3.f. : Insurer's Effective Date.
.;I(N,8)- ;Field 3.g :Termination date
.S ^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,"I")=^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,"I")_U_$E($G(I(N,2)),1,29)_U_$G(I(N,3))_U_$G(I(N,4))_U_$G(I(N,5))
.S ^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,"I")=^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,"I")_U_$G(I(N,6))_U_$$FMTE^XLFDT($G(I(N,7)))_U_$$FMTE^XLFDT($G(I(N,8)))
;
INSOTH1 ; other ins Box 3.h
S N="",I=0
I $D(I("B")) F S N=$O(I("B",N)) S I=I+2 Q:(N'?1N.N)!(I>6) D
.S $P(^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,"I"),U,7+I)=$P(I("B",N),U,1) ;INSURANCE TYPE
.S $P(^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,"I"),U,8+I)=$P(I("B",N),U,2) ;INSURANCE EFFECTIVE DATE
;
FIN ;
;$G(E(9))-EST CHARGES BOX 8
;$G(F(7))-COMMON ACCOUNT NUMBER BOX 9
;$G(F(9))-OBJECT CLASS CODE BOX 10
S ^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,1)=^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,1)_U_$G(E(9))_U_$G(F(7))_U_$G(F(9))
;
DOS ;
;C(5)-AUTH FROM DATE-BOX 11
;C(6)-AUTH TO DATE-BOX 11
S ^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,1)=^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,1)_U_$G(C(5))_U_$G(C(6))
DIAG ;
;R("D",1)-R("D",2)-R("D",3)-DIAGNOSIS NARATIVE-BOX 13
S ^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,2)=$G(R("D",1))_U_$G(R("D",2))_U_$G(R("D",3))
PROC ;
;R("P",1)-F(8)-R("P",2)-R("P",3)-R("P",4)-PROCEDURE NARATIVE-SSC-BOX 12
S ^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,2)=^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,2)_U_$G(R("P",1))_U_$G(R("P",2))_U_$G(R("P",3))_U_$G(R("P",4))_U_"SCC: "_$G(F(8))
REF ;
;R(1)-REFERRING PHY-BOX 14
;R(2)-Medical Priority-BOX 16
S ^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,2)=^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,2)_U_$G(R(1))_U_$G(R(2))
;
RATE ;PRICING INFORMATION SEGMENT
;F(6) MEDICARE PROVIDER NUM Skip contract section
I ACHSMPP S ^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,3)=F(6) G RATE2
;CONTRACT-AGREEMENT-RATE QUOT OR OPEN MARKET-BOX 17 OF FORM
S $P(^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,3),U,2)=$S(D(10)=13:"C",D(10)=24:"A",D(10)=37:"R",1:"O")
I $D(D(9)) D
.I $P($G(^ACHSF(DUZ(2),0)),U,8)="Y" S ^TMP=D(9) Q
.I $E(D(9),1,3)'="HHS",'$F("235^239^241^242^243^244^245^246^247^248^249^285",$E(D(9),1,3)) S D(9)="HHSI"_ACHSARCO_"-"_D(9)
.I $E(D(9),1,3)'="HHS",$F("235^239^241^242^243^244^245^246^247^248^249^285",$E(D(9),1,3)) S D(9)="HHSI"_"-"_D(9)
.S ACHSLTH=$L(D(9)) I $E(D(9),ACHSLTH)'="C" S D(9)=D(9)_"C"
S $P(^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,3),U,3)=D(9)
RATE2 ;
;D(11)-Date of Rate Quot-box 18
;ACHSMPP-MEDICARE- YES OR NO Box 19 A
;D(13)-D(15) Box 19 description
S $P(^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,3),U,4,7)=$G(D(11))_U_$G(ACHSMPP)_U_$G(D(13))_U_$G(D(15))
SIG ;
;TITLE BOX 20
;SIGNATURE-ORDERING BOX 21
;DATE SIGNED-BOX 22
I ACHSESIG'="" S ^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,4)=ACHSSIG_U_$P(ACHSESIG,",",2)_" "_$P(ACHSESIG,",",1)_" E-Signature"_U_ACHSEDTE
E S ^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,4)=ACHSSIG_U_U_E(7)
;SIGNATURE-AUTH OFF BOX 23
;DATE SIGNED BOX 24
;AMOUNT AUTH BOX 25
;ACHS*3.1*19 ADDED U TO LINE BELOW
I ACHSASIG'="" S $P(^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,4),U,4,6)=$P(ACHSASIG,",",2)_" "_$P(ACHSASIG,",",1)_" E-Signature"_U_ACHSADTE_U_E(9)
PROVIDER ;BOX 26
;D(1) PROVIDER NAME
;D(6) PROVIDER TEL
;D(2) PROV ADDRESS-LINE 1
;D(3) PROV ADDRESS-LINE 2
;D(4) EIN
;D(8) UPIN OR DUNS PAR NEEDS TO BE SET
;D(14) PROV CLASS BOX 27 "S" "SD" "SW" "SH" OR "O"
;
S ^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,5)=$G(D(1))_U_$G(D(6))_U_$G(D(2))_U_$G(D(3))_U_$G(D(4))_U_$G(D(8))_U_$G(D(14))
;
S I="",I=$O(^ACHS(4,0))
I ACHSDEST="F" S $P(^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,5),U,8,9)=$P($G(^ACHS(4,I,0)),U)_U_$P($G(^ACHS(4,I,0)),U,2)_" "_$P($G(^ACHS(4,I,0)),U,3)_","_$P($G(^DIC(5,$P($G(^ACHS(4,I,0)),U,4),0)),U,2)_" "_$P($G(^ACHS(4,I,0)),U,5)
E I ACHSDEST="I" S $P(^TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN,5),U,8,9)=B(1)_U_B(2)_" "_B(3)
;
KILL ;
;
K A,B,C,D,E,F,I,N,R,X
Q
;
FORMAT ;
PVT ;
Q:DFN=""
S (DA,N)=0
G MCR:'$D(^AUPNPRVT(DFN,11))
PVT1 ;
F S DA=$O(^AUPNPRVT(DFN,11,DA)) Q:'DA D
. S N=N+1,ACHSINS=$G(^AUPNPRVT(DFN,11,DA,0))
. D DINAPI
. I ACHSBZD("OK")="N" S N=N-1 Q
. F I=1:1:8 S I(N,I)=""
. S I(N,1)=$P(ACHSINS,U,4),I(N,2)=$P(ACHSINS,U)
. I $P(ACHSINS,U,8)'="",$D(^AUPN3PPH($P(ACHSINS,U,8),0)) D
. .S I(N,5)=$P(^AUPN3PPH($P(ACHSINS,U,8),0),U,4)
. .S I(N,6)=$P(^AUPN3PPH($P(ACHSINS,U,8),0),U,5)
. S I(N,7)=$P(ACHSINS,U,6),I(N,8)=$P(ACHSINS,U,7)
. S ACHSINS1=^AUTNINS(I(N,2),0),I(N,2)=$P(ACHSINS1,U),I(N,3)=$P(ACHSINS1,U,2)
. I $P(ACHSINS1,U,4),$D(^DIC(5,$P(ACHSINS1,U,4),0)) S X=$P(^(0),U,2),I(N,4)=$P(ACHSINS1,U,3)_", "_X_" "_$P(ACHSINS1,U,5)
. S:$G(I(N,6)) I(N,6)=$P(^AUTTPIC(I(N,6),0),U)
. I (ACHSIPRM="N"),((I(N,8)'<ACHSFDT)!(I(N,8)="")) S ACHSIPRM="Y",I("P",N)="" Q
. S:$G(I(N,7)) I(N,7)=$$FMTE^XLFDT(I(N,7))
. S:$G(I(N,8)) I(N,8)=$$FMTE^XLFDT(I(N,8))
. S I("B",N)=$E(I(N,2),1,(38-$L(I(N,5))))_" "_I(N,5)_"^EFF:"_I(N,7)_" "_I(N,8)
. K I(N)
MCR ;
S N=N+1
G MCD:'$D(^AUPNMCR("B",DFN))
S ACHSMR=N,ACHSMDFN=0,ACHSMDFN=$O(^AUPNMCR("B",DFN,ACHSMDFN)),ACHSINS=$G(^AUPNMCR(ACHSMDFN,0))
G:$P(ACHSINS,U,3)="" MCD
D DINACK("^AUPNMCR")
G MCD:ACHSBZD("OK")="N"
;
S I(N,5)=$P(ACHSINS,U,3)
S:$P(ACHSINS,U,4)'="" I(N,5)=I(N,5)_$P(^AUTTMCS($P(ACHSINS,U,4),0),U)
S I(N,1)=$S($D(^AUPNMCR(ACHSMDFN,21)):$P(^(21),U),'$D(^(21)):$P($G(^DPT(DFN,0)),U))
D SET("^AUPNMCR")
MCD ;
G RRE:'$D(^AUPNMCD("B",DFN))
S ACHSMDFN=0,ACHSMR=N
F S ACHSMDFN=$O(^AUPNMCD("B",DFN,ACHSMDFN)) Q:ACHSMDFN'?1N.N D Q:ACHSBZD("OK")="Y"
.D DINACK("^AUPNMCD")
.Q:ACHSBZD("OK")="N"
.S ACHSINS=$G(^AUPNMCD(ACHSMDFN,0)),I(N,5)=$P(ACHSINS,U,3),I(N,1)=$P(ACHSINS,U,5)
.D SET("^AUPNMCD")
RRE ;
G END:'$D(^AUPNRRE("B",DFN))
S ACHSMDFN=0,ACHSMR=N,ACHSMDFN=$O(^AUPNRRE("B",DFN,ACHSMDFN))
G:ACHSMDFN="" END
;
D DINACK("^AUPNRRE")
G END:ACHSBZD("OK")="N"
;
S ACHSINS=$G(^AUPNRRE(ACHSMDFN,0)),I(N,5)=$P(ACHSINS,U,3),I(N,1)=$P(ACHSINS,U,5)
D SET("^AUPNRRE")
END ;
K ACHSMDFN,DA,ACHSGL,ACHSINS,ACHSINS1,ACHSMR,ACHSBZD
Q
;
SET(ACHSGL) ;
S:$P(ACHSINS,U,2)'="" I(N,2)=$P($G(^AUTNINS($P(ACHSINS,U,2),0)),U)
S DA=0
F S DA=$O(@ACHSGL@(ACHSMDFN,11,DA)) Q:'DA D ;S N=N+1 dmh commented
. S I(N,6)=$P(@ACHSGL@(ACHSMDFN,11,DA,0),U,3),I(N,7)=$P(^(0),U),I(N,8)=$P(^(0),U,2)
. Q:(ACHSBZD("DT")<I(N,7)) ; -- ACHSBZD("DT") gets set from DINACK
. Q:(I(N,8)'="")&(ACHSBZD("DT")>I(N,8)) ; -- ACHSBZD("DT") gets set from DINACK
. I ACHSIPRM="N" S ACHSIPRM="Y",I("P",N)="" Q
. S I(N,7)=$$FMTE^XLFDT(I(N,7))
. S I(N,8)=$$FMTE^XLFDT(I(N,8))
. S I("B",N)=$E(I(ACHSMR,2),1,(37-$L(I(ACHSMR,5))-$L(I(N,6))))_" "_I(ACHSMR,5)_" "_I(N,6)_"^EFF:"_I(N,7)_" "_I(N,8)
. K:N'=ACHSMR I(N)
. S N=N+1
Q
;
DINACK(ACHSINSZ) ;
;-- Check for eligibility at Date Of Service. Else, no print.
;-- ACHSINSZ contains the name of the insurance global.
;
S ACHSBZD("OK")="N"
Q:'$D(C(5))
S X=C(5),%DT=""
D ^%DT
S ACHSBZD("DT")=Y,ACHSBZD("I")=0
F S ACHSBZD("I")=$O(@ACHSINSZ@(ACHSMDFN,11,ACHSBZD("I"))) Q:ACHSBZD("I")="" D Q:ACHSBZD("OK")="Y"
. S ACHSBZD("REC")=@ACHSINSZ@(ACHSMDFN,11,ACHSBZD("I"),0)
. S ACHSBZD("B")=$P(ACHSBZD("REC"),U),ACHSBZD("E")=$P(ACHSBZD("REC"),U,2)
. I (ACHSBZD("DT")'<ACHSBZD("B"))&(ACHSBZD("DT")'>ACHSBZD("E")) S ACHSBZD("OK")="Y" Q
. I (ACHSBZD("DT")'<ACHSBZD("B"))&(ACHSBZD("E")="") S ACHSBZD("OK")="Y" Q
Q
;
DINAPI ;-- Check for PI eligibility at Date Of Service. Else, no print.
S ACHSBZD("OK")="N"
Q:'$D(C(5))
S X=C(5),%DT=""
D ^%DT
S ACHSBZD("DT")=Y
S ACHSBZD("B")=$P(ACHSINS,U,6),ACHSBZD("E")=$P(ACHSINS,U,7)
I (ACHSBZD("DT")'<ACHSBZD("B"))&(ACHSBZD("DT")'>ACHSBZD("E")) S ACHSBZD("OK")="Y" Q
I (ACHSBZD("DT")'<ACHSBZD("B"))&(ACHSBZD("E")="") S ACHSBZD("OK")="Y" Q
Q
;
ACHSRPFU ; IHS/OIT/FCJ - PRINT CHS FORM AND DATA 3 OF 3;JUL 10, 2008 ; 30 Jun 2011 10:10 AM
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**18,19,20**;JUN 11,2001
+2 ;ACHS*3.1*18 4.29.2010 IHS.OIT.FCJ NEW ROUTINE
+3 ;SET VARIABLES IN TMP("ACHSPO",$J,ACHSDIEN,ACHSTIEN
+4 ;CALLED BY ACHSRPF1
+5 ;
INS ;
+1 ;SET PRIMARY INS FLAG TO NO
SET ACHSIPRM="N"
+2 ;GET INS INF
DO FORMAT
+3 DO SB1^ACHSRPF
+4 ;INITIALIZE INS SUBSCRIPT
SET N=""
+5 ;
PONUM ; -- Field 1 : DCR #, Document type, PDO number.
+1 ;
+2 SET ACHSDOFY=$PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,27)
+3 SET ACHSCTYP=$SELECT($PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,2)),U,9)'="":$PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,2),U,9),1:"")
+4 IF $DATA(ACHSCTYP)
IF ACHSCTYP'=""
SET ACHSCTYP=$PIECE(^ACHSCTYP(ACHSCTYP,0),U,2)
+5 SET ACHSDHHS="HHSI"_$PIECE($GET(^ACHSF(DUZ(2),0)),U,11)_ACHSDOFY_$EXTRACT(ACHSORDN,3,5)_$EXTRACT(ACHSORDN,7,11)_ACHSCTYP
+6 ;ACHS*3.1*19
SET ACHS3TY=""
IF $$PARM^ACHS(2,20)="Y"
SET ACHS3TY=$SELECT(ACHSTYPV=1:323,ACHSTYPV=2:324,1:325)
+7 SET ACHSPO=$EXTRACT($PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,27),3)_ACHSORDN
+8 ;ACHS*3.1*19 MODIFIED DCR IN NEXT LINE
+9 IF $$PARM^ACHS(2,18)="N"
Begin DoDot:1
End DoDot:1
SET ACHSDCR=""
+10 SET ^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,0)=ACHSPO_U_ACHSDHHS_U_ACHSTYPE_U_ACHSDCR_U_ACHS3TY_U_ACHSSF_U_$SELECT($DATA(ACHSBLKF):1,1:"")_U_E(11)_U_ACHSTYPV
+11 ;
ORDFAC ;
+1 ;$G(B(1)) ORDERING FACILITY NAME
+2 ;$G(B(4)) ORDERING FACILITY NUMBER
+3 ;$G(B(2)) ORDERING FACILITY ADDRESS
+4 ;$G(B(3)) ORDERING FACILITY ADDRESS
+5 SET ^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,0)=^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,0)_U_$GET(B(1))_U_$GET(B(4))_U_$GET(B(2))_U_$GET(B(3))
+6 ;
PAT ;Pat Ident-Box 2
+1 ;A(2)-PATIENT NAME
+2 ;A(3)-PATIENT CITY, STATE, ZIP
+3 ;A(11)-SSN
+4 ;V=VERIFIED BY SSA;A=SSN ADDED BY SSA;N=FAC SSN NOT = TO SSA SSN;D=SSN MATCHES SSA-DATA DIFFERS;P=PEND VER;X=SSA COULD NOT VERIFY/SUPPLY SSN
+5 SET ACHSSNS=""
IF $GET(DFN)
SET ACHSSSNS=$$SSV^ACHSTX3(DFN)
IF "PVX"[ACHSSSNS
SET $PIECE(^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,1),U,3)=ACHSSNS
+6 SET ^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,1)=$GET(A(2))_U_$GET(A(3))_U_$GET(A(11))_U_ACHSSNS
+7 IF $DATA(ACHSBLKF)
SET $PIECE(^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,1),U)="** BLANKET **"
PATO ; OTHER INFO
+1 ;A(1)-FACHRN
+2 ;A(4)-A(5) AGE SEX COMCODE
+3 ;A(7)-DESCRIPTION
+4 SET ^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,1)=^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,1)_U_$EXTRACT($GET(A(1)),1,27)_U_$GET(A(4))_" "_$GET(A(5))_U_"Desc: "_$GET(A(7))
+5 ;
INSPRM ;Primary INS INFO
+1 ;Field 3.a. : Name of Policy Holder.
+2 IF ACHSIPRM="Y"
Begin DoDot:1
+3 SET N=$ORDER(I("P",N))
+4 SET ACHSIPRM=N
+5 SET $PIECE(^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,"I"),U)=$EXTRACT(I(N,1),1,22)
End DoDot:1
+6 IF N'=""
Begin DoDot:1
+7 ;I(N,2)-Field 3.b. : Plan Name.
+8 ;I(N,3)-Field 3.c. : Insurer's address.
+9 ;I(N,4)-Insurer's addrs, cont.
+10 ;I(N,5)-Field 3.d. : Insurer's Policy Number.
+11 ;I(N,6)-Field 3.e. : Insurer's Coverage Type.
+12 ;I(N,7)-Field 3.f. : Insurer's Effective Date.
+13 ;I(N,8)- ;Field 3.g :Termination date
+14 SET ^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,"I")=^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,"I")_U_$EXTRACT($GET(I(N,2)),1,29)_U_$GET(I(N,3))_U_$GET(I(N,4))_U_$GET(I(N,5))
+15 SET ^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,"I")=^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,"I")_U_$GET(I(N,6))_U_$$FMTE^XLFDT($GET(I(N,7)))_U_$$FMTE^XLFDT($GET(I(N,8)))
End DoDot:1
+16 ;
INSOTH1 ; other ins Box 3.h
+1 SET N=""
SET I=0
+2 IF $DATA(I("B"))
FOR
SET N=$ORDER(I("B",N))
SET I=I+2
IF (N'?1N.N)!(I>6)
QUIT
Begin DoDot:1
+3 ;INSURANCE TYPE
SET $PIECE(^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,"I"),U,7+I)=$PIECE(I("B",N),U,1)
+4 ;INSURANCE EFFECTIVE DATE
SET $PIECE(^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,"I"),U,8+I)=$PIECE(I("B",N),U,2)
End DoDot:1
+5 ;
FIN ;
+1 ;$G(E(9))-EST CHARGES BOX 8
+2 ;$G(F(7))-COMMON ACCOUNT NUMBER BOX 9
+3 ;$G(F(9))-OBJECT CLASS CODE BOX 10
+4 SET ^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,1)=^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,1)_U_$GET(E(9))_U_$GET(F(7))_U_$GET(F(9))
+5 ;
DOS ;
+1 ;C(5)-AUTH FROM DATE-BOX 11
+2 ;C(6)-AUTH TO DATE-BOX 11
+3 SET ^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,1)=^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,1)_U_$GET(C(5))_U_$GET(C(6))
DIAG ;
+1 ;R("D",1)-R("D",2)-R("D",3)-DIAGNOSIS NARATIVE-BOX 13
+2 SET ^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,2)=$GET(R("D",1))_U_$GET(R("D",2))_U_$GET(R("D",3))
PROC ;
+1 ;R("P",1)-F(8)-R("P",2)-R("P",3)-R("P",4)-PROCEDURE NARATIVE-SSC-BOX 12
+2 SET ^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,2)=^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,2)_U_$GET(R("P",1))_U_$GET(R("P",2))_U_$GET(R("P",3))_U_$GET(R("P",4))_U_"SCC: "_$GET(F(8))
REF ;
+1 ;R(1)-REFERRING PHY-BOX 14
+2 ;R(2)-Medical Priority-BOX 16
+3 SET ^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,2)=^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,2)_U_$GET(R(1))_U_$GET(R(2))
+4 ;
RATE ;PRICING INFORMATION SEGMENT
+1 ;F(6) MEDICARE PROVIDER NUM Skip contract section
+2 IF ACHSMPP
SET ^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,3)=F(6)
GOTO RATE2
+3 ;CONTRACT-AGREEMENT-RATE QUOT OR OPEN MARKET-BOX 17 OF FORM
+4 SET $PIECE(^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,3),U,2)=$SELECT(D(10)=13:"C",D(10)=24:"A",D(10)=37:"R",1:"O")
+5 IF $DATA(D(9))
Begin DoDot:1
+6 IF $PIECE($GET(^ACHSF(DUZ(2),0)),U,8)="Y"
SET ^TMP=D(9)
QUIT
+7 IF $EXTRACT(D(9),1,3)'="HHS"
IF '$FIND("235^239^241^242^243^244^245^246^247^248^249^285",$EXTRACT(D(9),1,3))
SET D(9)="HHSI"_ACHSARCO_"-"_D(9)
+8 IF $EXTRACT(D(9),1,3)'="HHS"
IF $FIND("235^239^241^242^243^244^245^246^247^248^249^285",$EXTRACT(D(9),1,3))
SET D(9)="HHSI"_"-"_D(9)
+9 SET ACHSLTH=$LENGTH(D(9))
IF $EXTRACT(D(9),ACHSLTH)'="C"
SET D(9)=D(9)_"C"
End DoDot:1
+10 SET $PIECE(^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,3),U,3)=D(9)
RATE2 ;
+1 ;D(11)-Date of Rate Quot-box 18
+2 ;ACHSMPP-MEDICARE- YES OR NO Box 19 A
+3 ;D(13)-D(15) Box 19 description
+4 SET $PIECE(^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,3),U,4,7)=$GET(D(11))_U_$GET(ACHSMPP)_U_$GET(D(13))_U_$GET(D(15))
SIG ;
+1 ;TITLE BOX 20
+2 ;SIGNATURE-ORDERING BOX 21
+3 ;DATE SIGNED-BOX 22
+4 IF ACHSESIG'=""
SET ^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,4)=ACHSSIG_U_$PIECE(ACHSESIG,",",2)_" "_$PIECE(ACHSESIG,",",1)_" E-Signature"_U_ACHSEDTE
+5 IF '$TEST
SET ^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,4)=ACHSSIG_U_U_E(7)
+6 ;SIGNATURE-AUTH OFF BOX 23
+7 ;DATE SIGNED BOX 24
+8 ;AMOUNT AUTH BOX 25
+9 ;ACHS*3.1*19 ADDED U TO LINE BELOW
+10 IF ACHSASIG'=""
SET $PIECE(^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,4),U,4,6)=$PIECE(ACHSASIG,",",2)_" "_$PIECE(ACHSASIG,",",1)_" E-Signature"_U_ACHSADTE_U_E(9)
PROVIDER ;BOX 26
+1 ;D(1) PROVIDER NAME
+2 ;D(6) PROVIDER TEL
+3 ;D(2) PROV ADDRESS-LINE 1
+4 ;D(3) PROV ADDRESS-LINE 2
+5 ;D(4) EIN
+6 ;D(8) UPIN OR DUNS PAR NEEDS TO BE SET
+7 ;D(14) PROV CLASS BOX 27 "S" "SD" "SW" "SH" OR "O"
+8 ;
+9 SET ^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,5)=$GET(D(1))_U_$GET(D(6))_U_$GET(D(2))_U_$GET(D(3))_U_$GET(D(4))_U_$GET(D(8))_U_$GET(D(14))
+10 ;
+11 SET I=""
SET I=$ORDER(^ACHS(4,0))
+12 IF ACHSDEST="F"
SET $PIECE(^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,5),U,8,9)=$PIECE($GET(^ACHS(4,I,0)),U)_U_$PIECE($GET(^ACHS(4,I,0)),U,2)_" "_$PIECE($GET(^ACHS(4,I,0)),U,3)_","_$PIECE($GET(^DIC(5,$PIECE($GET(^ACHS(4,I,0)),U,4),0)),U,2)_" "_$PIECE(...
... $GET(^ACHS(4,I,0)),U,5)
+13 IF '$TEST
IF ACHSDEST="I"
SET $PIECE(^TMP("ACHSPO",$JOB,ACHSDIEN,ACHSTIEN,5),U,8,9)=B(1)_U_B(2)_" "_B(3)
+14 ;
KILL ;
+1 ;
+2 KILL A,B,C,D,E,F,I,N,R,X
+3 QUIT
+4 ;
FORMAT ;
PVT ;
+1 IF DFN=""
QUIT
+2 SET (DA,N)=0
+3 IF '$DATA(^AUPNPRVT(DFN,11))
GOTO MCR
PVT1 ;
+1 FOR
SET DA=$ORDER(^AUPNPRVT(DFN,11,DA))
IF 'DA
QUIT
Begin DoDot:1
+2 SET N=N+1
SET ACHSINS=$GET(^AUPNPRVT(DFN,11,DA,0))
+3 DO DINAPI
+4 IF ACHSBZD("OK")="N"
SET N=N-1
QUIT
+5 FOR I=1:1:8
SET I(N,I)=""
+6 SET I(N,1)=$PIECE(ACHSINS,U,4)
SET I(N,2)=$PIECE(ACHSINS,U)
+7 IF $PIECE(ACHSINS,U,8)'=""
IF $DATA(^AUPN3PPH($PIECE(ACHSINS,U,8),0))
Begin DoDot:2
+8 SET I(N,5)=$PIECE(^AUPN3PPH($PIECE(ACHSINS,U,8),0),U,4)
+9 SET I(N,6)=$PIECE(^AUPN3PPH($PIECE(ACHSINS,U,8),0),U,5)
End DoDot:2
+10 SET I(N,7)=$PIECE(ACHSINS,U,6)
SET I(N,8)=$PIECE(ACHSINS,U,7)
+11 SET ACHSINS1=^AUTNINS(I(N,2),0)
SET I(N,2)=$PIECE(ACHSINS1,U)
SET I(N,3)=$PIECE(ACHSINS1,U,2)
+12 IF $PIECE(ACHSINS1,U,4)
IF $DATA(^DIC(5,$PIECE(ACHSINS1,U,4),0))
SET X=$PIECE(^(0),U,2)
SET I(N,4)=$PIECE(ACHSINS1,U,3)_", "_X_" "_$PIECE(ACHSINS1,U,5)
+13 IF $GET(I(N,6))
SET I(N,6)=$PIECE(^AUTTPIC(I(N,6),0),U)
+14 IF (ACHSIPRM="N")
IF ((I(N,8)'<ACHSFDT)!(I(N,8)=""))
SET ACHSIPRM="Y"
SET I("P",N)=""
QUIT
+15 IF $GET(I(N,7))
SET I(N,7)=$$FMTE^XLFDT(I(N,7))
+16 IF $GET(I(N,8))
SET I(N,8)=$$FMTE^XLFDT(I(N,8))
+17 SET I("B",N)=$EXTRACT(I(N,2),1,(38-$LENGTH(I(N,5))))_" "_I(N,5)_"^EFF:"_I(N,7)_" "_I(N,8)
+18 KILL I(N)
End DoDot:1
MCR ;
+1 SET N=N+1
+2 IF '$DATA(^AUPNMCR("B",DFN))
GOTO MCD
+3 SET ACHSMR=N
SET ACHSMDFN=0
SET ACHSMDFN=$ORDER(^AUPNMCR("B",DFN,ACHSMDFN))
SET ACHSINS=$GET(^AUPNMCR(ACHSMDFN,0))
+4 IF $PIECE(ACHSINS,U,3)=""
GOTO MCD
+5 DO DINACK("^AUPNMCR")
+6 IF ACHSBZD("OK")="N"
GOTO MCD
+7 ;
+8 SET I(N,5)=$PIECE(ACHSINS,U,3)
+9 IF $PIECE(ACHSINS,U,4)'=""
SET I(N,5)=I(N,5)_$PIECE(^AUTTMCS($PIECE(ACHSINS,U,4),0),U)
+10 SET I(N,1)=$SELECT($DATA(^AUPNMCR(ACHSMDFN,21)):$PIECE(^(21),U),'$DATA(^(21)):$PIECE($GET(^DPT(DFN,0)),U))
+11 DO SET("^AUPNMCR")
MCD ;
+1 IF '$DATA(^AUPNMCD("B",DFN))
GOTO RRE
+2 SET ACHSMDFN=0
SET ACHSMR=N
+3 FOR
SET ACHSMDFN=$ORDER(^AUPNMCD("B",DFN,ACHSMDFN))
IF ACHSMDFN'?1N.N
QUIT
Begin DoDot:1
+4 DO DINACK("^AUPNMCD")
+5 IF ACHSBZD("OK")="N"
QUIT
+6 SET ACHSINS=$GET(^AUPNMCD(ACHSMDFN,0))
SET I(N,5)=$PIECE(ACHSINS,U,3)
SET I(N,1)=$PIECE(ACHSINS,U,5)
+7 DO SET("^AUPNMCD")
End DoDot:1
IF ACHSBZD("OK")="Y"
QUIT
RRE ;
+1 IF '$DATA(^AUPNRRE("B",DFN))
GOTO END
+2 SET ACHSMDFN=0
SET ACHSMR=N
SET ACHSMDFN=$ORDER(^AUPNRRE("B",DFN,ACHSMDFN))
+3 IF ACHSMDFN=""
GOTO END
+4 ;
+5 DO DINACK("^AUPNRRE")
+6 IF ACHSBZD("OK")="N"
GOTO END
+7 ;
+8 SET ACHSINS=$GET(^AUPNRRE(ACHSMDFN,0))
SET I(N,5)=$PIECE(ACHSINS,U,3)
SET I(N,1)=$PIECE(ACHSINS,U,5)
+9 DO SET("^AUPNRRE")
END ;
+1 KILL ACHSMDFN,DA,ACHSGL,ACHSINS,ACHSINS1,ACHSMR,ACHSBZD
+2 QUIT
+3 ;
SET(ACHSGL) ;
+1 IF $PIECE(ACHSINS,U,2)'=""
SET I(N,2)=$PIECE($GET(^AUTNINS($PIECE(ACHSINS,U,2),0)),U)
+2 SET DA=0
+3 ;S N=N+1 dmh commented
FOR
SET DA=$ORDER(@ACHSGL@(ACHSMDFN,11,DA))
IF 'DA
QUIT
Begin DoDot:1
+4 SET I(N,6)=$PIECE(@ACHSGL@(ACHSMDFN,11,DA,0),U,3)
SET I(N,7)=$PIECE(^(0),U)
SET I(N,8)=$PIECE(^(0),U,2)
+5 ; -- ACHSBZD("DT") gets set from DINACK
IF (ACHSBZD("DT")<I(N,7))
QUIT
+6 ; -- ACHSBZD("DT") gets set from DINACK
IF (I(N,8)'="")&(ACHSBZD("DT")>I(N,8))
QUIT
+7 IF ACHSIPRM="N"
SET ACHSIPRM="Y"
SET I("P",N)=""
QUIT
+8 SET I(N,7)=$$FMTE^XLFDT(I(N,7))
+9 SET I(N,8)=$$FMTE^XLFDT(I(N,8))
+10 SET I("B",N)=$EXTRACT(I(ACHSMR,2),1,(37-$LENGTH(I(ACHSMR,5))-$LENGTH(I(N,6))))_" "_I(ACHSMR,5)_" "_I(N,6)_"^EFF:"_I(N,7)_" "_I(N,8)
+11 IF N'=ACHSMR
KILL I(N)
+12 SET N=N+1
End DoDot:1
+13 QUIT
+14 ;
DINACK(ACHSINSZ) ;
+1 ;-- Check for eligibility at Date Of Service. Else, no print.
+2 ;-- ACHSINSZ contains the name of the insurance global.
+3 ;
+4 SET ACHSBZD("OK")="N"
+5 IF '$DATA(C(5))
QUIT
+6 SET X=C(5)
SET %DT=""
+7 DO ^%DT
+8 SET ACHSBZD("DT")=Y
SET ACHSBZD("I")=0
+9 FOR
SET ACHSBZD("I")=$ORDER(@ACHSINSZ@(ACHSMDFN,11,ACHSBZD("I")))
IF ACHSBZD("I")=""
QUIT
Begin DoDot:1
+10 SET ACHSBZD("REC")=@ACHSINSZ@(ACHSMDFN,11,ACHSBZD("I"),0)
+11 SET ACHSBZD("B")=$PIECE(ACHSBZD("REC"),U)
SET ACHSBZD("E")=$PIECE(ACHSBZD("REC"),U,2)
+12 IF (ACHSBZD("DT")'<ACHSBZD("B"))&(ACHSBZD("DT")'>ACHSBZD("E"))
SET ACHSBZD("OK")="Y"
QUIT
+13 IF (ACHSBZD("DT")'<ACHSBZD("B"))&(ACHSBZD("E")="")
SET ACHSBZD("OK")="Y"
QUIT
End DoDot:1
IF ACHSBZD("OK")="Y"
QUIT
+14 QUIT
+15 ;
DINAPI ;-- Check for PI eligibility at Date Of Service. Else, no print.
+1 SET ACHSBZD("OK")="N"
+2 IF '$DATA(C(5))
QUIT
+3 SET X=C(5)
SET %DT=""
+4 DO ^%DT
+5 SET ACHSBZD("DT")=Y
+6 SET ACHSBZD("B")=$PIECE(ACHSINS,U,6)
SET ACHSBZD("E")=$PIECE(ACHSINS,U,7)
+7 IF (ACHSBZD("DT")'<ACHSBZD("B"))&(ACHSBZD("DT")'>ACHSBZD("E"))
SET ACHSBZD("OK")="Y"
QUIT
+8 IF (ACHSBZD("DT")'<ACHSBZD("B"))&(ACHSBZD("E")="")
SET ACHSBZD("OK")="Y"
QUIT
+9 QUIT
+10 ;
