ACHSRPFU.m

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)=""))