ABMDESL1.m

ABMDESL1 ; IHS/ASDST/DMJ - Selective Looping Parameters-PART 2 ; 

 ;;2.6;IHS 3P BILLING SYSTEM;**11,21**;NOV 12, 2009;Build 379

 ;

 ;IHS/SD/SDR - v2.5 p10 - IM13359 - Added code to select range of patients

 ;IHS/SD/SDR - 2.6*21 - VMBP - Updated documentation from p11 to contain Serena ref#s

 ;

LOC ;EP for selecting location

 W ! K DIC,ABMY("LOC")

 S DIC="^BAR(90052.05,DUZ(2),"

 S DIC(0)="AEQM"

 S DIC("A")="Select LOCATION: "

 D ^DIC K DIC

 Q:+Y<1

 S ABMY("LOC")=+Y

 Q

 ;

TYP ;EP for selecting Billing Entity

 K DIR,ABMY("TYP"),ABMY("INS"),ABMY("PAT")

 ;S DIR(0)="SO^1:MEDICARE;2:MEDICAID;3:PRIVATE INSURANCE;4:NON-BENEFICIARY PATIENTS;5:BENEFICIARY PATIENTS;6:SPECIFIC INSURER"  ;abm*2.6*11 VMBP#8 RQMT_101

 S DIR(0)="SO^1:MEDICARE;2:MEDICAID;3:PRIVATE INSURANCE;4:NON-BENEFICIARY PATIENTS;5:BENEFICIARY PATIENTS;6:SPECIFIC INSURER;7:VETERANS MEDICAL BENEFIT PROG"  ;abm*2.6*11 VMBP#8 RQMT_101

 ;I '$D(ABMY("RNG")) S DIR(0)=DIR(0)_";7:SPECIFIC PATIENT"  ;abm*2.6*11 VMBP#8 RQM1_101

 I '$D(ABMY("RNG")) S DIR(0)=DIR(0)_";8:SPECIFIC PATIENT"  ;abm*2.6*11 VMBP#8 RQM1_101

 S DIR("A")="Select TYPE of BILLING ENTITY to Display"

 D ^DIR K DIR Q:$D(DIRUT)!$D(DIROUT)

 ;start old code abm*2.6*11 VMBP#8 RQM1_101

 ;S ABMY("TYP")=$S(Y=1:"R",Y=2:"D",Y=3:"P",Y=4:"N",Y=5:"I",1:Y),ABMY("TYP","NM")=Y(0)

 ;G INS:Y=6,PAT:Y=7

 ;end old code start new code VMBP#8 RQM1_101

 S ABMY("TYP")=$S(Y=1:"R",Y=2:"D",Y=3:"P",Y=4:"N",Y=5:"I",Y=7:"V",1:Y),ABMY("TYP","NM")=Y(0)

 G INS:Y=6,PAT:Y=8

 ;end new code VMBP#8 RQM1_101

 Q

 ;

INS K ABMY("TYP"),ABMY("INS") W ! S DIC="^AUTNINS(",DIC(0)="QEAM" D ^DIC

 Q:+Y<1  S ABMY("INS")=+Y

 Q

 ;

PAT K ABMY("TYP"),ABMY("PAT")

 W ! S DIC="^AUPNPAT(",DIC(0)="QEAM" D ^DIC K AUPNLK("ALL")

 Q:+Y<1  S ABMY("PAT")=+Y

 Q

 ;

DT ;EP for selecting Visit Date Range

 K DIR,ABMY("DT")

 S ABMY("DT")="V"

 S Y="VISIT DATE"

 W !!," ============ Entry of ",Y," Range ============="

 W ! S DIR("A")="Enter STARTING "_Y_" for the Looping",DIR(0)="DO^::E" D ^DIR

 I $D(DIRUT)!$D(DIROUT) K ABMY("DT"),DIR Q

 S ABMY("DT",1)=Y

 W ! S DIR("A")="Enter ENDING DATE for the Looping" D ^DIR K DIR

 I $D(DIRUT)!$D(DIROUT) K ABMY("DT") Q

 S ABMY("DT",2)=Y

 I ABMY("DT",1)>ABMY("DT",2) W !!,*7,"INPUT ERROR: Start Date is Greater than than the End Date, TRY AGAIN!",!! G DT

 Q

 ;

CLN ;EP for selecting CLINIC

 K ABMY("CLN"),DIC W ! S DIC="^DIC(40.7,",DIC(0)="QEAM" D ^DIC

 S:+Y>0 ABMY("CLN")=+Y

 Q

 ;

VTYP ;EP for selecting Visit Type

 K ABMY("VTYP"),DIC W ! S DIC="^ABMDVTYP(",DIC(0)="QEAM" D ^DIC

 S:+Y>0 ABMY("VTYP")=+Y

 Q

 ;

PRV ;EP for selecting Provider

 K ABMY("PRV"),DIC W ! S DIC="^VA(200,",DIC(0)="QEAM" D ^DIC

 S:+Y>0 ABMY("PRV")=+Y

 Q

 ;

ELIG ;EP for selecting Bene Class

 K DIR S DIR(0)="SO^1:INDIAN BENEFICIARY PATIENTS;2:NON-BENEFICIARY PATIENTS"

 S DIR("A")="Select the PATIENT ELIGIBILITY STATUS"

 S DIR("?")="Selection of an Eligibility Status will restrict the report to only those visits in which the patient is of the type designated."

 D ^DIR K DIR Q:$D(DIRUT)

 S ABMY("PTYP")=Y,ABMY("PTYP","NM")=Y(0)

 Q

RANGE ;

 K DIR,ABMY("RNG")

STARTR W !!,"Select RANGE OF PATIENTS to display:"

 W ! S DIR("A")="Start with Patient Name"

 S DIR("?")="Response must be three alpha characters"

 S DIR(0)="F^3:3" D ^DIR

 I $D(DIRUT)!$D(DIROUT) K ABMY("RNG"),DIR Q

 S ABMCK=$$ALPHACK(Y)

 I ABMCK=0 W !!?4,"Must be alpha characters only! (NO numbers, punctuation, etc)" K Y G STARTR

 S ABMY("RNG",1)=$$UPC^ABMERUTL(Y)

ENDR W !

 S DIR(0)="F^3:3"

 S DIR("?")="Response must be three alpha characters"

 S DIR("B")=$G(ABMY("RNG",1))

 S DIR("A")="Go to Patient Name" D ^DIR K DIR

 I $D(DIRUT)!$D(DIROUT) K ABMY("RNG") Q

 S ABMCK=$$ALPHACK(Y)

 I ABMCK=0 W !!?4,"Must be alpha characters only! (NO numbers, punctuaton, etc)" K Y G ENDR

 S ABMY("RNG",2)=$$UPC^ABMERUTL(Y)

 D SEQCK  ;check if start name before go to name

 I '$D(ABMY("RNG")) W !!?4,"Invalid range...please try again!" G RANGE

 Q

ALPHACK(X) ;

 N ABMI,ABMTST,ABMPCE

 N ABMCK

 S ABMCK=1

 S ABMTST=$$UPC^ABMERUTL(X)

 S ABMI=""

 F ABMI=1:1:$L(ABMTST) D

 .S ABMPCE=$E(ABMTST,ABMI)

 .I $A(ABMPCE)<65 S ABMCK=0  ;before A

 .I $A(ABMPCE)>90 S ABMCK=0  ;after Z

 Q ABMCK

SEQCK ;

 K ABMPCE

 F ABMI=1,2 D

 .F ABMJ=1:1:3 D

 ..S ABMPCE(ABMI)=$G(ABMPCE(ABMI))_$A($E(ABMY("RNG",ABMI),ABMJ))

 I ABMPCE(1)>ABMPCE(2) K ABMY("RNG")

 Q

ABMDESL1  ; IHS/ASDST/DMJ - Selective Looping Parameters-PART 2 ; 

 +1       ;;2.6;IHS 3P BILLING SYSTEM;**11,21**;NOV 12, 2009;Build 379

 +2       ;

 +3       ;IHS/SD/SDR - v2.5 p10 - IM13359 - Added code to select range of patients

 +4       ;IHS/SD/SDR - 2.6*21 - VMBP - Updated documentation from p11 to contain Serena ref#s

 +5       ;

LOC       ;EP for selecting location

 +1        WRITE !

           KILL DIC,ABMY("LOC")

 +2        SET DIC="^BAR(90052.05,DUZ(2),"

 +3        SET DIC(0)="AEQM"

 +4        SET DIC("A")="Select LOCATION: "

 +5        DO ^DIC

           KILL DIC

 +6        IF +Y<1

               QUIT 

 +7        SET ABMY("LOC")=+Y

 +8        QUIT 

 +9       ;

TYP       ;EP for selecting Billing Entity

 +1        KILL DIR,ABMY("TYP"),ABMY("INS"),ABMY("PAT")

 +2       ;S DIR(0)="SO^1:MEDICARE;2:MEDICAID;3:PRIVATE INSURANCE;4:NON-BENEFICIARY PATIENTS;5:BENEFICIARY PATIENTS;6:SPECIFIC INSURER"  ;abm*2.6*11 VMBP#8 RQMT_101

 +3       ;abm*2.6*11 VMBP#8 RQMT_101

           SET DIR(0)="SO^1:MEDICARE;2:MEDICAID;3:PRIVATE INSURANCE;4:NON-BENEFICIARY PATIENTS;5:BENEFICIARY PATIENTS;6:SPECIFIC INSURER;7:VETERANS MEDICAL BENEFIT PROG"

 +4       ;I '$D(ABMY("RNG")) S DIR(0)=DIR(0)_";7:SPECIFIC PATIENT"  ;abm*2.6*11 VMBP#8 RQM1_101

 +5       ;abm*2.6*11 VMBP#8 RQM1_101

           IF '$DATA(ABMY("RNG"))

               SET DIR(0)=DIR(0)_";8:SPECIFIC PATIENT"

 +6        SET DIR("A")="Select TYPE of BILLING ENTITY to Display"

 +7        DO ^DIR

           KILL DIR

           IF $DATA(DIRUT)!$DATA(DIROUT)

               QUIT 

 +8       ;start old code abm*2.6*11 VMBP#8 RQM1_101

 +9       ;S ABMY("TYP")=$S(Y=1:"R",Y=2:"D",Y=3:"P",Y=4:"N",Y=5:"I",1:Y),ABMY("TYP","NM")=Y(0)

 +10      ;G INS:Y=6,PAT:Y=7

 +11      ;end old code start new code VMBP#8 RQM1_101

 +12       SET ABMY("TYP")=$SELECT(Y=1:"R",Y=2:"D",Y=3:"P",Y=4:"N",Y=5:"I",Y=7:"V",1:Y)

           SET ABMY("TYP","NM")=Y(0)

 +13       IF Y=6

               GOTO INS

           IF Y=8

               GOTO PAT

 +14      ;end new code VMBP#8 RQM1_101

 +15       QUIT 

 +16      ;

INS        KILL ABMY("TYP"),ABMY("INS")

           WRITE !

           SET DIC="^AUTNINS("

           SET DIC(0)="QEAM"

           DO ^DIC

 +1        IF +Y<1

               QUIT 

           SET ABMY("INS")=+Y

 +2        QUIT 

 +3       ;

PAT        KILL ABMY("TYP"),ABMY("PAT")

 +1        WRITE !

           SET DIC="^AUPNPAT("

           SET DIC(0)="QEAM"

           DO ^DIC

           KILL AUPNLK("ALL")

 +2        IF +Y<1

               QUIT 

           SET ABMY("PAT")=+Y

 +3        QUIT 

 +4       ;

DT        ;EP for selecting Visit Date Range

 +1        KILL DIR,ABMY("DT")

 +2        SET ABMY("DT")="V"

 +3        SET Y="VISIT DATE"

 +4        WRITE !!," ============ Entry of ",Y," Range ============="

 +5        WRITE !

           SET DIR("A")="Enter STARTING "_Y_" for the Looping"

           SET DIR(0)="DO^::E"

           DO ^DIR

 +6        IF $DATA(DIRUT)!$DATA(DIROUT)

               KILL ABMY("DT"),DIR

               QUIT 

 +7        SET ABMY("DT",1)=Y

 +8        WRITE !

           SET DIR("A")="Enter ENDING DATE for the Looping"

           DO ^DIR

           KILL DIR

 +9        IF $DATA(DIRUT)!$DATA(DIROUT)

               KILL ABMY("DT")

               QUIT 

 +10       SET ABMY("DT",2)=Y

 +11       IF ABMY("DT",1)>ABMY("DT",2)

               WRITE !!,*7,"INPUT ERROR: Start Date is Greater than than the End Date, TRY AGAIN!",!!

               GOTO DT

 +12       QUIT 

 +13      ;

CLN       ;EP for selecting CLINIC

 +1        KILL ABMY("CLN"),DIC

           WRITE !

           SET DIC="^DIC(40.7,"

           SET DIC(0)="QEAM"

           DO ^DIC

 +2        IF +Y>0

               SET ABMY("CLN")=+Y

 +3        QUIT 

 +4       ;

VTYP      ;EP for selecting Visit Type

 +1        KILL ABMY("VTYP"),DIC

           WRITE !

           SET DIC="^ABMDVTYP("

           SET DIC(0)="QEAM"

           DO ^DIC

 +2        IF +Y>0

               SET ABMY("VTYP")=+Y

 +3        QUIT 

 +4       ;

PRV       ;EP for selecting Provider

 +1        KILL ABMY("PRV"),DIC

           WRITE !

           SET DIC="^VA(200,"

           SET DIC(0)="QEAM"

           DO ^DIC

 +2        IF +Y>0

               SET ABMY("PRV")=+Y

 +3        QUIT 

 +4       ;

ELIG      ;EP for selecting Bene Class

 +1        KILL DIR

           SET DIR(0)="SO^1:INDIAN BENEFICIARY PATIENTS;2:NON-BENEFICIARY PATIENTS"

 +2        SET DIR("A")="Select the PATIENT ELIGIBILITY STATUS"

 +3        SET DIR("?")="Selection of an Eligibility Status will restrict the report to only those visits in which the patient is of the type designated."

 +4        DO ^DIR

           KILL DIR

           IF $DATA(DIRUT)

               QUIT 

 +5        SET ABMY("PTYP")=Y

           SET ABMY("PTYP","NM")=Y(0)

 +6        QUIT 

RANGE     ;

 +1        KILL DIR,ABMY("RNG")

STARTR     WRITE !!,"Select RANGE OF PATIENTS to display:"

 +1        WRITE !

           SET DIR("A")="Start with Patient Name"

 +2        SET DIR("?")="Response must be three alpha characters"

 +3        SET DIR(0)="F^3:3"

           DO ^DIR

 +4        IF $DATA(DIRUT)!$DATA(DIROUT)

               KILL ABMY("RNG"),DIR

               QUIT 

 +5        SET ABMCK=$$ALPHACK(Y)

 +6        IF ABMCK=0

               WRITE !!?4,"Must be alpha characters only! (NO numbers, punctuation, etc)"

               KILL Y

               GOTO STARTR

 +7        SET ABMY("RNG",1)=$$UPC^ABMERUTL(Y)

ENDR       WRITE !

 +1        SET DIR(0)="F^3:3"

 +2        SET DIR("?")="Response must be three alpha characters"

 +3        SET DIR("B")=$GET(ABMY("RNG",1))

 +4        SET DIR("A")="Go to Patient Name"

           DO ^DIR

           KILL DIR

 +5        IF $DATA(DIRUT)!$DATA(DIROUT)

               KILL ABMY("RNG")

               QUIT 

 +6        SET ABMCK=$$ALPHACK(Y)

 +7        IF ABMCK=0

               WRITE !!?4,"Must be alpha characters only! (NO numbers, punctuaton, etc)"

               KILL Y

               GOTO ENDR

 +8        SET ABMY("RNG",2)=$$UPC^ABMERUTL(Y)

 +9       ;check if start name before go to name

           DO SEQCK

 +10       IF '$DATA(ABMY("RNG"))

               WRITE !!?4,"Invalid range...please try again!"

               GOTO RANGE

 +11       QUIT 

ALPHACK(X) ;

 +1        NEW ABMI,ABMTST,ABMPCE

 +2        NEW ABMCK

 +3        SET ABMCK=1

 +4        SET ABMTST=$$UPC^ABMERUTL(X)

 +5        SET ABMI=""

 +6        FOR ABMI=1:1:$LENGTH(ABMTST)

               Begin DoDot:1

 +7                SET ABMPCE=$EXTRACT(ABMTST,ABMI)

 +8       ;before A

                   IF $ASCII(ABMPCE)<65

                       SET ABMCK=0

 +9       ;after Z

                   IF $ASCII(ABMPCE)>90

                       SET ABMCK=0

               End DoDot:1

 +10       QUIT ABMCK

SEQCK     ;

 +1        KILL ABMPCE

 +2        FOR ABMI=1,2

               Begin DoDot:1

 +3                FOR ABMJ=1:1:3

                       Begin DoDot:2

 +4                        SET ABMPCE(ABMI)=$GET(ABMPCE(ABMI))_$ASCII($EXTRACT(ABMY("RNG",ABMI),ABMJ))

                       End DoDot:2

               End DoDot:1

 +5        IF ABMPCE(1)>ABMPCE(2)

               KILL ABMY("RNG")

 +6        QUIT