AUPNELIG.m

AUPNELIG ; IHS/CMI/LAB - IHS-CMB/TMD INPUT TRANSFORMS FOR INSURED FIELDS OF THE ELIGIBILTY FILES ;

 ;;99.1;IHS DICTIONARIES (PATIENT);;MAR 09, 1999

  ;;93.1;IHS PATIENT DICTIONARIES.;;DEC 07, 1992

HLPPI S ABMDX="HELP-PI" G DIC

HLPMCD S ABMDX="HELP-MCD" G DIC

PI S ABMDX="PI" G DIC

MCD S ABMDX="MCD"

DIC S:X="?" X="??" S ABMDX(0)=DA,ABMDX("X")=X

 I ABMDX["PI" S ABMDX(1)=DA(1)

 N (ABMDX,DUZ,DT,DTIME,U,X) S DIC="^AUPN3PPH(",DIC(0)="E"

 I ABMDX["PI" S ABMDX("INSP")=$P(^AUPNPRVT(ABMDX(1),11,ABMDX(0),0),U),ABMDX("POLP")=$P(^(0),U,2),ABMDX("PAT")=ABMDX(1)

 I ABMDX["MCD" S ABMDX("STATE")=$P(^AUPNMCD(ABMDX(0),0),U,4),ABMDX("POLP")=$P(^(0),U,3),ABMDX("PAT")=$P(^(0),U),ABMDX("INSP")=$P(^(0),U,2) D

 .I ABMDX("INSP")=""!(ABMDX("STATE")="") Q

 .S:ABMDX("INSP")=$P($G(^AUTNINS(ABMDX("INSP"),13,ABMDX("STATE"),0)),U,2)]"" ABMDX("INSP")=$P(^(0),U,2)

 S DIC("S")="I $P(^(0),U,3)=ABMDX(""INSP"")!($P(^(0),U,3)="""")"

 I ABMDX'["HELP" W !!,"Searching POLICY HOLDER file ....",!

 S %=0 D ^DIC

 I ABMDX["HELP" G XIT

 I Y=-1 S X=ABMDX("X") G INSD3

 W ?15,$P(Y,U,2) S ABMDX("Y")=Y

 S ABMDX("INSD")=$P(^AUPN3PPH(+Y,0),U,3),ABMDX("POLD")=$P(^AUPN3PPH(+Y,0),U,4)

 I ABMDX("INSD")=ABMDX("INSP"),ABMDX("POLP")=ABMDX("POLD") S X=$P(Y,U,2) G INSDIE

 I ABMDX("INSD")="" S %=0 G INSD2

 I ABMDX("INSD")'=ABMDX("INSP") S X=ABMDX("X") G INSD3

 I ABMDX("POLD")=""!(ABMDX("POLP")="") S %=0 G INSD2

 I ABMDX("POLD")'=ABMDX("POLP") W *7,!!?10,"WARNING - Policy Numbers DO NOT MATCH!",*7 ;S X=ABMDX("X") G INSD3

 ;

INSD2 W !!?5,"Is the following person:",!!?10,"POLICY HOLDER",?25,"-  ",$P(Y,U,2),!?10,"INSURANCE CO.",?25,"-  " I ABMDX("INSD")]"",$D(^AUTNINS(ABMDX("INSD"),0)) W $P(^AUTNINS(ABMDX("INSD"),0),U)

 W !?10,"POLICY NUMBER",?25,"-  ",ABMDX("POLD")

 W !!?5,"the correct insured policy holder for ",$P(^DPT(ABMDX("PAT"),0),U)

 D YN^DICN I %<1 W *7,!!?15,"Enter 'Y' for YES or 'N' for NO" G INSD2

 I %'=1 S X=ABMDX("X") G INSD3

 S ABMDX("X")=$P(Y,U,2),ABMDX("Y")=Y,DIE="^AUPN3PPH(",DA=+Y

 I ABMDX("INSD")="" S DR=".03////"_ABMDX("INSP") D ^DIE

 I ABMDX("POLD")=""&(ABMDX("POLP")'="") S DR=".04////"_ABMDX("POLP") D ^DIE

 ;E  I ABMDX("POLP")'=ABMDX("POLD") S DA(1)=ABMDX(1),DIE="^AUPNPRVT("_DA(1)_",11,",DA=ABMDX(0),DR=".02////"_ABMDX("POLD") D ^DIE 

 S X=ABMDX("X"),Y=ABMDX("Y") G INSDIE

 ;

INSD3 K DIC S DIC="^DPT(",X=ABMDX("X"),DIC(0)="EM"

 W !!,"Searching PATIENT file ...." D ^DIC

 S X=ABMDX("X") I Y=-1 G CHK

 W "   ",$P(Y,U,2)

 I $P(Y,U,2)=X G ADD

PAT S ABMDX("Y")=Y W !!,"Is ",$P(Y,U,2)," the correct insured policy holder for ",$P(^DPT(ABMDX("PAT"),0),U)

 S %=1 D YN^DICN I %<1 W *7 G PAT

 I %=1 S (ABMDX("X"),X)=$P(^DPT(+ABMDX("Y"),0),U) G ADD2

CHK K:X[""""!(X'?1U.UNP)!(X'[",")!(X?.E1","." ")!(X?.E1","." "1",".E)!($L(X,",")>3)!($L(X)>30)!($L(X)<3) X I $D(X) F L=1:0 S L=$F(X," ",L) Q:L=0  S:$E(X,L-2)?1P!($E(X,L)?1P)!(L>$L(X)) X=$E(X,1,L-2)_$E(X,L,99),L=L-1

 I '$D(X) W !!?10,"No Lookup Match Found, or Improper Format for New Entry" G XIT

 ;

ADD W !!,"Do you wish to add ",X," as the Insured Policy Holder"

 S %=1 D YN^DICN I %'=1 K X G XIT

ADD2 S DIC="^AUPN3PPH(",DIC(0)="L" K DD,DO D FILE^DICN

 S ABMDX("Y")=Y,AMBDX("X")=$P(Y,U,2)

 S ABMDX("DR")=""

 I $D(^DPT("B",X))=10 S ABMDX("DR")=$O(^DPT("B",X,"")),ABMDX("DR")=".02////"_ABMDX("DR")_";"

 S DIE="^AUPN3PPH(",DR=ABMDX("DR")_".03////"_ABMDX("INSP")_";.04////"_ABMDX("POLP"),DA=+Y D ^DIE

 S X=ABMDX("X"),Y=ABMDX("Y")

 ;

INSDIE S ABMDX("DR")="" I $P(^AUPN3PPH(+ABMDX("Y"),0),U,2)']"" S ABMDX("DR")=".08;.09;.11;.12;.13;.14;.15;.21;.22;.23;.24;.25"

 S ABMDX("X")=X,DIE="^AUPN3PPH(",DA=+ABMDX("Y"),DR=ABMDX("DR")_".04;.05;.06;.07" D ^DIE

 ;I '$D(^AUPN3PPH(+ABMDX("Y"),11,0)) S ^AUPN3PPH(+ABMDX("Y"),11,0)="^9002274.0911P^^"

 ;I '$D(^AUPN3PPH(+ABMDX("Y"),11,ABMDX(1),0)) K DD,DO,DR S DIC="^AUPN3PPH(",DIC(0)="E" D DO^DIC1 S (X,DINUM)=$S(ABMDX["PI":ABMDX(1),1:ABMDX(0)),DA(1)=+ABMDX("Y"),DIC="^AUPN3PPH("_DA(1)_",11,",DIC(0)="L" D FILE^DICN

 ;

 ;

 I ABMDX["PI" S DA(1)=ABMDX(1),DIE="^AUPNPRVT("_DA(1)_",11,",DA=ABMDX(0),DR=".08////"_+ABMDX("Y") D ^DIE

 I ABMDX["MCD" S DIE="^AUPNMCD(",DA=ABMDX(0),DR=".09////"_+ABMDX("Y") D ^DIE

 S X=ABMDX("X")

XIT K ABMDX Q

AUPNELIG  ; IHS/CMI/LAB - IHS-CMB/TMD INPUT TRANSFORMS FOR INSURED FIELDS OF THE ELIGIBILTY FILES ;

 +1       ;;99.1;IHS DICTIONARIES (PATIENT);;MAR 09, 1999

 +2       ;;93.1;IHS PATIENT DICTIONARIES.;;DEC 07, 1992

HLPPI      SET ABMDX="HELP-PI"

           GOTO DIC

HLPMCD     SET ABMDX="HELP-MCD"

           GOTO DIC

PI         SET ABMDX="PI"

           GOTO DIC

MCD        SET ABMDX="MCD"

DIC        IF X="?"

               SET X="??"

           SET ABMDX(0)=DA

           SET ABMDX("X")=X

 +1        IF ABMDX["PI"

               SET ABMDX(1)=DA(1)

 +2        NEW (ABMDX,DUZ,DT,DTIME,U,X)

           SET DIC="^AUPN3PPH("

           SET DIC(0)="E"

 +3        IF ABMDX["PI"

               SET ABMDX("INSP")=$PIECE(^AUPNPRVT(ABMDX(1),11,ABMDX(0),0),U)

               SET ABMDX("POLP")=$PIECE(^(0),U,2)

               SET ABMDX("PAT")=ABMDX(1)

 +4        IF ABMDX["MCD"

               SET ABMDX("STATE")=$PIECE(^AUPNMCD(ABMDX(0),0),U,4)

               SET ABMDX("POLP")=$PIECE(^(0),U,3)

               SET ABMDX("PAT")=$PIECE(^(0),U)

               SET ABMDX("INSP")=$PIECE(^(0),U,2)

               Begin DoDot:1

 +5                IF ABMDX("INSP")=""!(ABMDX("STATE")="")

                       QUIT 

 +6                IF ABMDX("INSP")=$PIECE($GET(^AUTNINS(ABMDX("INSP"),13,ABMDX("STATE"),0)),U,2)]""

                       SET ABMDX("INSP")=$PIECE(^(0),U,2)

               End DoDot:1

 +7        SET DIC("S")="I $P(^(0),U,3)=ABMDX(""INSP"")!($P(^(0),U,3)="""")"

 +8        IF ABMDX'["HELP"

               WRITE !!,"Searching POLICY HOLDER file ....",!

 +9        SET %=0

           DO ^DIC

 +10       IF ABMDX["HELP"

               GOTO XIT

 +11       IF Y=-1

               SET X=ABMDX("X")

               GOTO INSD3

 +12       WRITE ?15,$PIECE(Y,U,2)

           SET ABMDX("Y")=Y

 +13       SET ABMDX("INSD")=$PIECE(^AUPN3PPH(+Y,0),U,3)

           SET ABMDX("POLD")=$PIECE(^AUPN3PPH(+Y,0),U,4)

 +14       IF ABMDX("INSD")=ABMDX("INSP")

               IF ABMDX("POLP")=ABMDX("POLD")

                   SET X=$PIECE(Y,U,2)

                   GOTO INSDIE

 +15       IF ABMDX("INSD")=""

               SET %=0

               GOTO INSD2

 +16       IF ABMDX("INSD")'=ABMDX("INSP")

               SET X=ABMDX("X")

               GOTO INSD3

 +17       IF ABMDX("POLD")=""!(ABMDX("POLP")="")

               SET %=0

               GOTO INSD2

 +18      ;S X=ABMDX("X") G INSD3

           IF ABMDX("POLD")'=ABMDX("POLP")

               WRITE *7,!!?10,"WARNING - Policy Numbers DO NOT MATCH!",*7

 +19      ;

INSD2      WRITE !!?5,"Is the following person:",!!?10,"POLICY HOLDER",?25,"-  ",$PIECE(Y,U,2),!?10,"INSURANCE CO.",?25,"-  "

           IF ABMDX("INSD")]""

               IF $DATA(^AUTNINS(ABMDX("INSD"),0))

                   WRITE $PIECE(^AUTNINS(ABMDX("INSD"),0),U)

 +1        WRITE !?10,"POLICY NUMBER",?25,"-  ",ABMDX("POLD")

 +2        WRITE !!?5,"the correct insured policy holder for ",$PIECE(^DPT(ABMDX("PAT"),0),U)

 +3        DO YN^DICN

           IF %<1

               WRITE *7,!!?15,"Enter 'Y' for YES or 'N' for NO"

               GOTO INSD2

 +4        IF %'=1

               SET X=ABMDX("X")

               GOTO INSD3

 +5        SET ABMDX("X")=$PIECE(Y,U,2)

           SET ABMDX("Y")=Y

           SET DIE="^AUPN3PPH("

           SET DA=+Y

 +6        IF ABMDX("INSD")=""

               SET DR=".03////"_ABMDX("INSP")

               DO ^DIE

 +7        IF ABMDX("POLD")=""&(ABMDX("POLP")'="")

               SET DR=".04////"_ABMDX("POLP")

               DO ^DIE

 +8       ;E  I ABMDX("POLP")'=ABMDX("POLD") S DA(1)=ABMDX(1),DIE="^AUPNPRVT("_DA(1)_",11,",DA=ABMDX(0),DR=".02////"_ABMDX("POLD") D ^DIE 

 +9        SET X=ABMDX("X")

           SET Y=ABMDX("Y")

           GOTO INSDIE

 +10      ;

INSD3      KILL DIC

           SET DIC="^DPT("

           SET X=ABMDX("X")

           SET DIC(0)="EM"

 +1        WRITE !!,"Searching PATIENT file ...."

           DO ^DIC

 +2        SET X=ABMDX("X")

           IF Y=-1

               GOTO CHK

 +3        WRITE "   ",$PIECE(Y,U,2)

 +4        IF $PIECE(Y,U,2)=X

               GOTO ADD

PAT        SET ABMDX("Y")=Y

           WRITE !!,"Is ",$PIECE(Y,U,2)," the correct insured policy holder for ",$PIECE(^DPT(ABMDX("PAT"),0),U)

 +1        SET %=1

           DO YN^DICN

           IF %<1

               WRITE *7

               GOTO PAT

 +2        IF %=1

               SET (ABMDX("X"),X)=$PIECE(^DPT(+ABMDX("Y"),0),U)

               GOTO ADD2

CHK        IF X[""""!(X'?1U.UNP)!(X'[",")!(X?.E1","." ")!(X?.E1","." "1",".E)!($LENGTH(X,",")>3)!($LENGTH(X)>30)!($LENGTH(X)<3)

               KILL X

           IF $DATA(X)

               FOR L=1:0

                   SET L=$FIND(X," ",L)

                   IF L=0

                       QUIT 

                   IF $EXTRACT(X,L-2)?1P!($EXTRACT(X,L)?1P)!(L>$LENGTH(X))

                       SET X=$EXTRACT(X,1,L-2)_$EXTRACT(X,L,99)

                       SET L=L-1

 +1        IF '$DATA(X)

               WRITE !!?10,"No Lookup Match Found, or Improper Format for New Entry"

               GOTO XIT

 +2       ;

ADD        WRITE !!,"Do you wish to add ",X," as the Insured Policy Holder"

 +1        SET %=1

           DO YN^DICN

           IF %'=1

               KILL X

               GOTO XIT

ADD2       SET DIC="^AUPN3PPH("

           SET DIC(0)="L"

           KILL DD,DO

           DO FILE^DICN

 +1        SET ABMDX("Y")=Y

           SET AMBDX("X")=$PIECE(Y,U,2)

 +2        SET ABMDX("DR")=""

 +3        IF $DATA(^DPT("B",X))=10

               SET ABMDX("DR")=$ORDER(^DPT("B",X,""))

               SET ABMDX("DR")=".02////"_ABMDX("DR")_";"

 +4        SET DIE="^AUPN3PPH("

           SET DR=ABMDX("DR")_".03////"_ABMDX("INSP")_";.04////"_ABMDX("POLP")

           SET DA=+Y

           DO ^DIE

 +5        SET X=ABMDX("X")

           SET Y=ABMDX("Y")

 +6       ;

INSDIE     SET ABMDX("DR")=""

           IF $PIECE(^AUPN3PPH(+ABMDX("Y"),0),U,2)']""

               SET ABMDX("DR")=".08;.09;.11;.12;.13;.14;.15;.21;.22;.23;.24;.25"

 +1        SET ABMDX("X")=X

           SET DIE="^AUPN3PPH("

           SET DA=+ABMDX("Y")

           SET DR=ABMDX("DR")_".04;.05;.06;.07"

           DO ^DIE

 +2       ;I '$D(^AUPN3PPH(+ABMDX("Y"),11,0)) S ^AUPN3PPH(+ABMDX("Y"),11,0)="^9002274.0911P^^"

 +3       ;I '$D(^AUPN3PPH(+ABMDX("Y"),11,ABMDX(1),0)) K DD,DO,DR S DIC="^AUPN3PPH(",DIC(0)="E" D DO^DIC1 S (X,DINUM)=$S(ABMDX["PI":ABMDX(1),1:ABMDX(0)),DA(1)=+ABMDX("Y"),DIC="^AUPN3PPH("_DA(1)_",11,",DIC(0)="L" D FILE^DICN

 +4       ;

 +5       ;

 +6        IF ABMDX["PI"

               SET DA(1)=ABMDX(1)

               SET DIE="^AUPNPRVT("_DA(1)_",11,"

               SET DA=ABMDX(0)

               SET DR=".08////"_+ABMDX("Y")

               DO ^DIE

 +7        IF ABMDX["MCD"

               SET DIE="^AUPNMCD("

               SET DA=ABMDX(0)

               SET DR=".09////"_+ABMDX("Y")

               DO ^DIE

 +8        SET X=ABMDX("X")

XIT        KILL ABMDX

           QUIT