ABMDVST7.m

ABMDVST7 ; IHS/ASDST/DMJ - PCC VISIT STUFF MEDICAL-SKIN TEST ; 

 ;;2.6;IHS Third Party Billing System;**2**;NOV 12, 2009

 ;Original;TMD;03/26/96 12:00 PM

 ; modifed to use the new extrinsic function

 ; skip this rtn

 ;

 ; IHS/SD/SDR - v2.6 CSV

 ; IHS/SD/SDR - abm*2.6*2 - 3PMS10003A - modified to call ABMFEAPI

 Q

 ; Delete this following code after alpha tesing

 K ABMR

SKIN S DA(1)=ABMP("CDFN"),DIC="^ABMDCLM(DUZ(2),"_DA(1)_",37,",DIC(0)="LE"

 S ABM="^AUPNVSK(""AD"","_ABMVDFN_")"

 F  S ABM=$Q(@ABM) Q:$P($P(ABM,"AD",2),",",2)'=ABMVDFN  K DIC("DR"),DD,DO S X=+$P($P(ABM,"AD",2),",",3) D SKCHK

 G EXAM

 ;

SKCHK Q:'$D(^AUPNVSK(X,0))  S ABMR("X")=$P($G(^AUTTSK(+^(0),0)),U,2) Q:'ABMR("X")

 S ABM("CPT")=$P($T(@ABMR("X")),";;",2) Q:'ABM("CPT")

 ;Q:$P($G(^ABMDFEE(ABMP("FEE"),17,ABM("CPT"),0)),U,2)<1  S ABMR("FEE")=$P(^(0),U,2)

 ;Q:($P($G(^ABMDFEE(ABMP("FEE"),17,ABM("CPT"),0)),U,2)&($P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,14)'="Y"))  ;abm*2.6*2 3PMS10003A

 Q:($P($$ONE^ABMFEAPI(ABMP("FEE"),17,ABM("CPT"),ABMP("VDT")),U)&($P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,14)'="Y"))  ;abm*2.6*2 3PMS10003A

 ;S ABMR("FEE")=$P($G(^ABMDFEE(ABMP("FEE"),17,ABM("CPT"),0)),U,2)  ;abm*2.6*2 3PMS10003A

 S ABMR("FEE")=$P($$ONE^ABMFEAPI(ABMP("FEE"),17,ABM("CPT"),ABMP("VDT")),U)  ;abm*2.6*2 3PMS10003A

 S X=ABM("CPT")

 I $D(ABMR(X)) S ABMR(X)=ABMR(X)+1

 E  S ABMR(X)=1

 S DIC("P")=$P(^DD(9002274.3,37,0),U,2)

 S DIC("DR")=".02////"_$S($P($$IHSCPT^ABMCVAPI(X,ABMP("VDT")),U,3):$P($$IHSCPT^ABMCVAPI(X,ABMP("VDT")),U,3),1:302)_";.03////"_ABMR(X)_";.04////"_ABMR("FEE")  ;CSV-c

 K DD,DO D FILE^DICN

 Q

 ;

EXAM K ABMR

 S DA(1)=ABMP("CDFN"),DIC="^ABMDCLM(DUZ(2),"_DA(1)_",27,",DIC(0)="LE"

 S ABM="^AUPNVXAM(""AD"","_ABMVDFN_")"

 F  S ABM=$Q(@ABM) Q:$P($P(ABM,"AD",2),",",2)'=ABMVDFN  K DIC("DR"),DD,DO S X=+$P($P(ABM,"AD",2),",",3) D EXCHK

 Q

 ;

EXCHK Q:'$D(^AUPNVXAM(X,0))  S ABMR("X")=$P($G(^AUTTEXAM(+^(0),0)),U,2) Q:'ABMR("X")

 S ABMR("X")="E"_ABMR("X"),ABM("CPT")=$P($T(@ABMR("X")),";;",2) Q:'ABM("CPT")

 ;Q:$P($G(^ABMDFEE(ABMP("FEE"),19,ABM("CPT"),0)),U,2)<1  S ABMR("FEE")=$P(^(0),U,2)

 ;Q:($P($G(^ABMDFEE(ABMP("FEE"),19,ABM("CPT"),0)),U,2)&($P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,14)'="Y"))  ;abm*2.6*2 3PMS10003A

 Q:($P($$ONE^ABMFEAPI(ABMP("FEE"),19,ABM("CPT"),ABMP("VDT")),U)&($P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,14)'="Y"))  ;abm*2.6*2 3PMS10003A

 ;S ABMR("FEE")=$P($G(^ABMDFEE(ABMP("FEE"),19,ABM("CPT"),0)),U,2)  ;abm*2.6*2 3PMS10003A

 S ABMR("FEE")=$P($$ONE^ABMFEAPI(ABMP("FEE"),19,ABM("CPT"),ABMP("VDT")),U)  ;abm*2.6*2 3PMS10003A

 S X=ABM("CPT")

 I $D(ABMR(X)) S ABMR(X)=ABMR(X)+1

 E  S ABMR(X)=1

 S DIC("P")=$P(^DD(9002274.3,27,0),U,2)

 S DIC("DR")=".02////"_$S($P($G(^ICPT(X,9999999)),U,2):$P(^(9999999),U,2),1:960)_";.03////"_ABMR(X)_";.04////"_ABMR("FEE")

 K DD,DO D FILE^DICN

 Q

 ;

20 ;;86585

21 ;;86580

22 ;;86580

23 ;;86490

24 ;;86580

E23 ;;92551

E24 ;;92552

E25 ;;92567

E26 ;;92100

ABMDVST7  ; IHS/ASDST/DMJ - PCC VISIT STUFF MEDICAL-SKIN TEST ; 

 +1       ;;2.6;IHS Third Party Billing System;**2**;NOV 12, 2009

 +2       ;Original;TMD;03/26/96 12:00 PM

 +3       ; modifed to use the new extrinsic function

 +4       ; skip this rtn

 +5       ;

 +6       ; IHS/SD/SDR - v2.6 CSV

 +7       ; IHS/SD/SDR - abm*2.6*2 - 3PMS10003A - modified to call ABMFEAPI

 +8        QUIT 

 +9       ; Delete this following code after alpha tesing

 +10       KILL ABMR

SKIN       SET DA(1)=ABMP("CDFN")

           SET DIC="^ABMDCLM(DUZ(2),"_DA(1)_",37,"

           SET DIC(0)="LE"

 +1        SET ABM="^AUPNVSK(""AD"","_ABMVDFN_")"

 +2        FOR 

               SET ABM=$QUERY(@ABM)

               IF $PIECE($PIECE(ABM,"AD",2),",",2)'=ABMVDFN

                   QUIT 

               KILL DIC("DR"),DD,DO

               SET X=+$PIECE($PIECE(ABM,"AD",2),",",3)

               DO SKCHK

 +3        GOTO EXAM

 +4       ;

SKCHK      IF '$DATA(^AUPNVSK(X,0))

               QUIT 

           SET ABMR("X")=$PIECE($GET(^AUTTSK(+^(0),0)),U,2)

           IF 'ABMR("X")

               QUIT 

 +1        SET ABM("CPT")=$PIECE($TEXT(@ABMR("X")),";;",2)

           IF 'ABM("CPT")

               QUIT 

 +2       ;Q:$P($G(^ABMDFEE(ABMP("FEE"),17,ABM("CPT"),0)),U,2)<1  S ABMR("FEE")=$P(^(0),U,2)

 +3       ;Q:($P($G(^ABMDFEE(ABMP("FEE"),17,ABM("CPT"),0)),U,2)&($P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,14)'="Y"))  ;abm*2.6*2 3PMS10003A

 +4       ;abm*2.6*2 3PMS10003A

           IF ($PIECE($$ONE^ABMFEAPI(ABMP("FEE"),17,ABM("CPT"),ABMP("VDT")),U)&($PIECE($GET(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,14)'="Y"))

               QUIT 

 +5       ;S ABMR("FEE")=$P($G(^ABMDFEE(ABMP("FEE"),17,ABM("CPT"),0)),U,2)  ;abm*2.6*2 3PMS10003A

 +6       ;abm*2.6*2 3PMS10003A

           SET ABMR("FEE")=$PIECE($$ONE^ABMFEAPI(ABMP("FEE"),17,ABM("CPT"),ABMP("VDT")),U)

 +7        SET X=ABM("CPT")

 +8        IF $DATA(ABMR(X))

               SET ABMR(X)=ABMR(X)+1

 +9       IF '$TEST

               SET ABMR(X)=1

 +10       SET DIC("P")=$PIECE(^DD(9002274.3,37,0),U,2)

 +11      ;CSV-c

           SET DIC("DR")=".02////"_$SELECT($PIECE($$IHSCPT^ABMCVAPI(X,ABMP("VDT")),U,3):$PIECE($$IHSCPT^ABMCVAPI(X,ABMP("VDT")),U,3),1:302)_";.03////"_ABMR(X)_";.04////"_ABMR("FEE")

 +12       KILL DD,DO

           DO FILE^DICN

 +13       QUIT 

 +14      ;

EXAM       KILL ABMR

 +1        SET DA(1)=ABMP("CDFN")

           SET DIC="^ABMDCLM(DUZ(2),"_DA(1)_",27,"

           SET DIC(0)="LE"

 +2        SET ABM="^AUPNVXAM(""AD"","_ABMVDFN_")"

 +3        FOR 

               SET ABM=$QUERY(@ABM)

               IF $PIECE($PIECE(ABM,"AD",2),",",2)'=ABMVDFN

                   QUIT 

               KILL DIC("DR"),DD,DO

               SET X=+$PIECE($PIECE(ABM,"AD",2),",",3)

               DO EXCHK

 +4        QUIT 

 +5       ;

EXCHK      IF '$DATA(^AUPNVXAM(X,0))

               QUIT 

           SET ABMR("X")=$PIECE($GET(^AUTTEXAM(+^(0),0)),U,2)

           IF 'ABMR("X")

               QUIT 

 +1        SET ABMR("X")="E"_ABMR("X")

           SET ABM("CPT")=$PIECE($TEXT(@ABMR("X")),";;",2)

           IF 'ABM("CPT")

               QUIT 

 +2       ;Q:$P($G(^ABMDFEE(ABMP("FEE"),19,ABM("CPT"),0)),U,2)<1  S ABMR("FEE")=$P(^(0),U,2)

 +3       ;Q:($P($G(^ABMDFEE(ABMP("FEE"),19,ABM("CPT"),0)),U,2)&($P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,14)'="Y"))  ;abm*2.6*2 3PMS10003A

 +4       ;abm*2.6*2 3PMS10003A

           IF ($PIECE($$ONE^ABMFEAPI(ABMP("FEE"),19,ABM("CPT"),ABMP("VDT")),U)&($PIECE($GET(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,14)'="Y"))

               QUIT 

 +5       ;S ABMR("FEE")=$P($G(^ABMDFEE(ABMP("FEE"),19,ABM("CPT"),0)),U,2)  ;abm*2.6*2 3PMS10003A

 +6       ;abm*2.6*2 3PMS10003A

           SET ABMR("FEE")=$PIECE($$ONE^ABMFEAPI(ABMP("FEE"),19,ABM("CPT"),ABMP("VDT")),U)

 +7        SET X=ABM("CPT")

 +8        IF $DATA(ABMR(X))

               SET ABMR(X)=ABMR(X)+1

 +9       IF '$TEST

               SET ABMR(X)=1

 +10       SET DIC("P")=$PIECE(^DD(9002274.3,27,0),U,2)

 +11       SET DIC("DR")=".02////"_$SELECT($PIECE($GET(^ICPT(X,9999999)),U,2):$PIECE(^(9999999),U,2),1:960)_";.03////"_ABMR(X)_";.04////"_ABMR("FEE")

 +12       KILL DD,DO

           DO FILE^DICN

 +13       QUIT 

 +14      ;

20        ;;86585

21        ;;86580

22        ;;86580

23        ;;86490

24        ;;86580

E23       ;;92551

E24       ;;92552

E25       ;;92567

E26       ;;92100