XBFUNC1.m

XBFUNC1 ; IHS/ADC/GTH - FUNCTION LIBRARY CONTINUED ; [ 02/07/97   3:02 PM ]

 ;;3.0;IHS/VA UTILITIES;;FEB 07, 1997

 ;

PROVCLS(PROV,FORM) ;PEP - Retrieve Provider Class from New Person File

 I $G(PROV)="" Q ""

 I '$D(^VA(200,PROV)) Q ""

 NEW X,Z,Y,CLS,DIC,DR,DA,DIQ

 S DIC=200,DR="53.5",DA=PROV,DIQ="CLS"

 S:$G(FORM)="I" DIQ(0)="I"

 D ENDIQ1

 S CLS=$S($G(FORM)="I":CLS(200,PROV,"53.5","I"),1:CLS(200,PROV,"53.5"))

 Q $S(CLS="":"UNKNOWN",1:CLS)

 ;

PROVCLSC(PROV) ;PEP - Retrieve Provider Class Code given New Person File IEN

 I $G(PROV)="" Q ""

 I '$D(^VA(200,PROV)) Q ""

 NEW X,Z,Y,CODE,DIC,DR,DA,DIQ,CLASS

 S CLASS=$$PROVCLS^XBFUNC1(PROV,"I")

 I CLASS="UNKNOWN" Q "UNKNOWN"

 S DIC=7,DR="9999999.01",DA=CLASS,DIQ="CODE"

 D ENDIQ1

 S CODE=CODE(7,CLASS,"9999999.01")

 Q $S(CODE="":"UNKNOWN",1:CODE)

 ;

PROVAFFL(PROV,FORM) ;PEP - Retrieve provider affiliation in int or ext format

 I $G(PROV)="" Q ""

 I '$D(^VA(200,PROV)) Q ""

 NEW X,Z,Y,AFFL,DIC,DR,DA,DIQ

 S DIC=200,DR="9999999.01",DA=PROV,DIQ="AFFL"

 S:$G(FORM)="I" DIQ(0)="I"

 D ENDIQ1

 S AFFL=$S($G(FORM)="I":AFFL(200,PROV,"9999999.01","I"),1:AFFL(200,PROV,"9999999.01"))

 Q AFFL

 ;

PROVCODE(PROV) ;PEP - Retrieve provider code

 I $G(PROV)="" Q ""

 I '$D(^VA(200,PROV)) Q ""

 NEW X,Z,Y,CODE,DIC,DR,DA,DIQ

 S DIC=200,DR="9999999.02",DA=PROV,DIQ="CODE",DIQ(0)="E"

 D ENDIQ1

 Q CODE(200,PROV,"9999999.02","E")

 ;

PROVINI(PROV) ;PEP - Retrieve provider initials

 I '$G(PROV) Q ""

 I '$D(^VA(200,PROV)) Q ""

 NEW X,Z,Y,INIT,DIC,DR,DA,DIQ

 S DIC=200,DR="1",DA=PROV,DIQ="INIT",DIQ(0)="E"

 D ENDIQ1

 Q INIT(200,PROV,"1","E")

 ;

ENDIQ1 ;

 NEW CLASS,FORM,PROV,X,Y,Z

 D EN^DIQ1

 Q

 ;

XBFUNC1   ; IHS/ADC/GTH - FUNCTION LIBRARY CONTINUED ; [ 02/07/97   3:02 PM ]

 +1       ;;3.0;IHS/VA UTILITIES;;FEB 07, 1997

 +2       ;

PROVCLS(PROV,FORM) ;PEP - Retrieve Provider Class from New Person File

 +1        IF $GET(PROV)=""

               QUIT ""

 +2        IF '$DATA(^VA(200,PROV))

               QUIT ""

 +3        NEW X,Z,Y,CLS,DIC,DR,DA,DIQ

 +4        SET DIC=200

           SET DR="53.5"

           SET DA=PROV

           SET DIQ="CLS"

 +5        IF $GET(FORM)="I"

               SET DIQ(0)="I"

 +6        DO ENDIQ1

 +7        SET CLS=$SELECT($GET(FORM)="I":CLS(200,PROV,"53.5","I"),1:CLS(200,PROV,"53.5"))

 +8        QUIT $SELECT(CLS="":"UNKNOWN",1:CLS)

 +9       ;

PROVCLSC(PROV) ;PEP - Retrieve Provider Class Code given New Person File IEN

 +1        IF $GET(PROV)=""

               QUIT ""

 +2        IF '$DATA(^VA(200,PROV))

               QUIT ""

 +3        NEW X,Z,Y,CODE,DIC,DR,DA,DIQ,CLASS

 +4        SET CLASS=$$PROVCLS^XBFUNC1(PROV,"I")

 +5        IF CLASS="UNKNOWN"

               QUIT "UNKNOWN"

 +6        SET DIC=7

           SET DR="9999999.01"

           SET DA=CLASS

           SET DIQ="CODE"

 +7        DO ENDIQ1

 +8        SET CODE=CODE(7,CLASS,"9999999.01")

 +9        QUIT $SELECT(CODE="":"UNKNOWN",1:CODE)

 +10      ;

PROVAFFL(PROV,FORM) ;PEP - Retrieve provider affiliation in int or ext format

 +1        IF $GET(PROV)=""

               QUIT ""

 +2        IF '$DATA(^VA(200,PROV))

               QUIT ""

 +3        NEW X,Z,Y,AFFL,DIC,DR,DA,DIQ

 +4        SET DIC=200

           SET DR="9999999.01"

           SET DA=PROV

           SET DIQ="AFFL"

 +5        IF $GET(FORM)="I"

               SET DIQ(0)="I"

 +6        DO ENDIQ1

 +7        SET AFFL=$SELECT($GET(FORM)="I":AFFL(200,PROV,"9999999.01","I"),1:AFFL(200,PROV,"9999999.01"))

 +8        QUIT AFFL

 +9       ;

PROVCODE(PROV) ;PEP - Retrieve provider code

 +1        IF $GET(PROV)=""

               QUIT ""

 +2        IF '$DATA(^VA(200,PROV))

               QUIT ""

 +3        NEW X,Z,Y,CODE,DIC,DR,DA,DIQ

 +4        SET DIC=200

           SET DR="9999999.02"

           SET DA=PROV

           SET DIQ="CODE"

           SET DIQ(0)="E"

 +5        DO ENDIQ1

 +6        QUIT CODE(200,PROV,"9999999.02","E")

 +7       ;

PROVINI(PROV) ;PEP - Retrieve provider initials

 +1        IF '$GET(PROV)

               QUIT ""

 +2        IF '$DATA(^VA(200,PROV))

               QUIT ""

 +3        NEW X,Z,Y,INIT,DIC,DR,DA,DIQ

 +4        SET DIC=200

           SET DR="1"

           SET DA=PROV

           SET DIQ="INIT"

           SET DIQ(0)="E"

 +5        DO ENDIQ1

 +6        QUIT INIT(200,PROV,"1","E")

 +7       ;

ENDIQ1    ;

 +1        NEW CLASS,FORM,PROV,X,Y,Z

 +2        DO EN^DIQ1

 +3        QUIT 

 +4       ;