Routine: XBFUNC2

XBFUNC2 ; IHS/ADC/GTH - FUNCTION LIBRARY : PCC RELATED FUNCTIONS ; [ 02/07/97   3:02 PM ]

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

PCCPPINT(XBVISIT) ;PEP - Return primary provider ien in VA(200

 NEW X,Y,Z,XBX,DIC,DR,DA,DIQ,XBY

 S XBX=0

 F  S XBX=$O(^AUPNVPRV("AD",XBVISIT,XBX)) Q:XBX'=+XBX  I $P(^AUPNVPRV(XBX,0),U,4)="P" S XBY=+^AUPNVPRV(XBX,0) Q

 I '$G(XBY) Q ""

 Q XBY

PCCPPN(XBVISIT) ;PEP - Return a visit's primary provider (NAME)

 NEW X,Y,Z,XBX,DIC,DR,DA,DIQ,XBY

 S XBX=0

 F  S XBX=$O(^AUPNVPRV("AD",XBVISIT,XBX)) Q:XBX'=+XBX  I $P(^AUPNVPRV(XBX,0),U,4)="P" S XBY=XBX Q

 I '$G(XBY) Q "NONE ENTERED"

 S XBX=$$VAL^XBDIQ1(9000010.06,XBY,.01)

 Q:XBX="" "NONE ENTERED"

 Q XBX

PCCPPI(XBVISIT) ;PEP - Return a visit's primary provider (INITIALS)

 NEW X,Y,Z,XBX,DIC,DR,DA,DIQ,XBY

 S XBX=0

 F  S XBX=$O(^AUPNVPRV("AD",XBVISIT,XBX)) Q:XBX'=+XBX  I $P(^AUPNVPRV(XBX,0),U,4)="P" S XBY=+^AUPNVPRV(XBX,0) Q

 I '$G(XBY) Q "???"

 S XBX=$$VAL^XBDIQ1($S($P($G(^AUTTSITE(1,0)),U,22):200,1:6),XBY,1)

 Q:XBX="" "???"

 Q XBX

PCCPPCLS(XBVISIT,FORM) ;PEP - Return a visit's primary provider class (CODE)

 NEW X,Y,Z,XBX,DIC,DR,DA,DIQ,XBY,XBCODE

 S XBX=0

 F  S XBX=$O(^AUPNVPRV("AD",XBVISIT,XBX)) Q:XBX'=+XBX  I $P(^AUPNVPRV(XBX,0),U,4)="P" S XBY=+^AUPNVPRV(XBX,0) Q

 I '$G(XBY) Q "???"

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

 S DA=XBY,DIC=$S($P($G(^AUTTSITE(1,0)),U,22):200,1:6),DR=$S($P($G(^AUTTSITE(1,0)),U,22):53.5,1:2),DIQ="XBX"

 D EN^DIQ1

 I $P($G(^AUTTSITE(1,0)),U,22) S XBX=$S($G(FORM)="I":$G(XBX(200,XBY,"53.5","I")),1:$G(XBX(200,XBY,"53.5")))

 I '$P($G(^AUTTSITE(1,0)),U,22) S XBX=$S($G(FORM)="I":$G(XBX(6,XBY,"2","I")),1:$G(XBX(6,XBY,"2")))

 I XBX="" Q "???"

 Q XBX

PCCPPCLC(XBVISIT) ;PEP - Return a visit's primary provider class (CODE)

 NEW X,Y,Z,XBX,DIC,DR,DA,DIQ,XBCODE,XBY,XBN

 S XBX=0

 F  S XBX=$O(^AUPNVPRV("AD",XBVISIT,XBX)) Q:XBX'=+XBX  I $P(^AUPNVPRV(XBX,0),U,4)="P" S XBY=+^AUPNVPRV(XBX,0) Q

 I '$G(XBY) Q "???"

 S DA=XBY,DIC=200,DR="53.5",DIQ="XBX",DIQ(0)="I"

 D EN^DIQ1

 S XBX=$G(XBX(200,XBY,"53.5","I"))

 Q:XBX="" "???"

 S DIC=7,DR="9999999.01",DA=XBX,DIQ="XBCODE"

 D EN^DIQ1

 S XBX=XBCODE(7,XBX,"9999999.01","I")

 Q XBX

PCCPPAFF(XBVISIT,FORM) ;PEP - Return a visit's primary provider (affiliation)

 NEW X,Y,Z,XBX,DIC,DR,DA,DIQ,XBY,XBN

 S XBX=0

 F  S XBX=$O(^AUPNVPRV("AD",XBVISIT,XBX)) Q:XBX'=+XBX  I $P(^AUPNVPRV(XBX,0),U,4)="P" S XBY=+^AUPNVPRV(XBX,0) Q

 I '$G(XBY) Q "???"

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

 S DA=XBY,DIC=$S($P($G(^AUTTSITE(1,0)),U,22):200,1:6),DR="9999999.01",DIQ="XBX"

 D EN^DIQ1

 I $P($G(^AUTTSITE(1,0)),U,22) S XBX=$S($G(FORM)="I":$G(XBX(200,XBY,9999999.01,"I")),1:$G(XBX(200,XBY,9999999.01)))

 I '$P($G(^AUTTSITE(1,0)),U,22) S XBX=$S($G(FORM)="I":$G(XBX(6,XBY,9999999.01,"I")),1:$G(XBX(6,XBY,9999999.01)))

 Q:XBX="" "???"

 Q XBX

XBFUNC2   ; IHS/ADC/GTH - FUNCTION LIBRARY : PCC RELATED FUNCTIONS ; [ 02/07/97   3:02 PM ]

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

 +2       ;

 +3       ;

PCCPPINT(XBVISIT) ;PEP - Return primary provider ien in VA(200

 +1        NEW X,Y,Z,XBX,DIC,DR,DA,DIQ,XBY

 +2        SET XBX=0

 +3        FOR

               SET XBX=$ORDER(^AUPNVPRV("AD",XBVISIT,XBX))

               IF XBX'=+XBX

                   QUIT

               IF $PIECE(^AUPNVPRV(XBX,0),U,4)="P"

                   SET XBY=+^AUPNVPRV(XBX,0)

                   QUIT

 +4        IF '$GET(XBY)

               QUIT ""

 +5        QUIT XBY

 +6       ;

PCCPPN(XBVISIT) ;PEP - Return a visit's primary provider (NAME)

 +1        NEW X,Y,Z,XBX,DIC,DR,DA,DIQ,XBY

 +2        SET XBX=0

 +3        FOR

               SET XBX=$ORDER(^AUPNVPRV("AD",XBVISIT,XBX))

               IF XBX'=+XBX

                   QUIT

               IF $PIECE(^AUPNVPRV(XBX,0),U,4)="P"

                   SET XBY=XBX

                   QUIT

 +4        IF '$GET(XBY)

               QUIT "NONE ENTERED"

 +5        SET XBX=$$VAL^XBDIQ1(9000010.06,XBY,.01)

 +6        IF XBX=""

               QUIT "NONE ENTERED"

 +7        QUIT XBX

 +8       ;

PCCPPI(XBVISIT) ;PEP - Return a visit's primary provider (INITIALS)

 +1        NEW X,Y,Z,XBX,DIC,DR,DA,DIQ,XBY

 +2        SET XBX=0

 +3        FOR

               SET XBX=$ORDER(^AUPNVPRV("AD",XBVISIT,XBX))

               IF XBX'=+XBX

                   QUIT

               IF $PIECE(^AUPNVPRV(XBX,0),U,4)="P"

                   SET XBY=+^AUPNVPRV(XBX,0)

                   QUIT

 +4        IF '$GET(XBY)

               QUIT "???"

 +5        SET XBX=$$VAL^XBDIQ1($SELECT($PIECE($GET(^AUTTSITE(1,0)),U,22):200,1:6),XBY,1)

 +6        IF XBX=""

               QUIT "???"

 +7        QUIT XBX

 +8       ;

PCCPPCLS(XBVISIT,FORM) ;PEP - Return a visit's primary provider class (CODE)

 +1        NEW X,Y,Z,XBX,DIC,DR,DA,DIQ,XBY,XBCODE

 +2        SET XBX=0

 +3        FOR

               SET XBX=$ORDER(^AUPNVPRV("AD",XBVISIT,XBX))

               IF XBX'=+XBX

                   QUIT

               IF $PIECE(^AUPNVPRV(XBX,0),U,4)="P"

                   SET XBY=+^AUPNVPRV(XBX,0)

                   QUIT

 +4        IF '$GET(XBY)

               QUIT "???"

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

               SET DIQ(0)="I"

 +6        SET DA=XBY

           SET DIC=$SELECT($PIECE($GET(^AUTTSITE(1,0)),U,22):200,1:6)

           SET DR=$SELECT($PIECE($GET(^AUTTSITE(1,0)),U,22):53.5,1:2)

           SET DIQ="XBX"

 +7        DO EN^DIQ1

 +8        IF $PIECE($GET(^AUTTSITE(1,0)),U,22)

               SET XBX=$SELECT($GET(FORM)="I":$GET(XBX(200,XBY,"53.5","I")),1:$GET(XBX(200,XBY,"53.5")))

 +9        IF '$PIECE($GET(^AUTTSITE(1,0)),U,22)

               SET XBX=$SELECT($GET(FORM)="I":$GET(XBX(6,XBY,"2","I")),1:$GET(XBX(6,XBY,"2")))

 +10       IF XBX=""

               QUIT "???"

 +11       QUIT XBX

 +12      ;

PCCPPCLC(XBVISIT) ;PEP - Return a visit's primary provider class (CODE)

 +1        NEW X,Y,Z,XBX,DIC,DR,DA,DIQ,XBCODE,XBY,XBN

 +2        SET XBX=0

 +3        FOR

               SET XBX=$ORDER(^AUPNVPRV("AD",XBVISIT,XBX))

               IF XBX'=+XBX

                   QUIT

               IF $PIECE(^AUPNVPRV(XBX,0),U,4)="P"

                   SET XBY=+^AUPNVPRV(XBX,0)

                   QUIT

 +4        IF '$GET(XBY)

               QUIT "???"

 +5        SET DA=XBY

           SET DIC=200

           SET DR="53.5"

           SET DIQ="XBX"

           SET DIQ(0)="I"

 +6        DO EN^DIQ1

 +7        SET XBX=$GET(XBX(200,XBY,"53.5","I"))

 +8        IF XBX=""

               QUIT "???"

 +9        SET DIC=7

           SET DR="9999999.01"

           SET DA=XBX

           SET DIQ="XBCODE"

 +10       DO EN^DIQ1

 +11       SET XBX=XBCODE(7,XBX,"9999999.01","I")

 +12       QUIT XBX

 +13      ;

PCCPPAFF(XBVISIT,FORM) ;PEP - Return a visit's primary provider (affiliation)

 +1        NEW X,Y,Z,XBX,DIC,DR,DA,DIQ,XBY,XBN

 +2        SET XBX=0

 +3        FOR

               SET XBX=$ORDER(^AUPNVPRV("AD",XBVISIT,XBX))

               IF XBX'=+XBX

                   QUIT

               IF $PIECE(^AUPNVPRV(XBX,0),U,4)="P"

                   SET XBY=+^AUPNVPRV(XBX,0)

                   QUIT

 +4        IF '$GET(XBY)

               QUIT "???"

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

               SET DIQ(0)="I"

 +6        SET DA=XBY

           SET DIC=$SELECT($PIECE($GET(^AUTTSITE(1,0)),U,22):200,1:6)

           SET DR="9999999.01"

           SET DIQ="XBX"

 +7        DO EN^DIQ1

 +8        IF $PIECE($GET(^AUTTSITE(1,0)),U,22)

               SET XBX=$SELECT($GET(FORM)="I":$GET(XBX(200,XBY,9999999.01,"I")),1:$GET(XBX(200,XBY,9999999.01)))

 +9        IF '$PIECE($GET(^AUTTSITE(1,0)),U,22)

               SET XBX=$SELECT($GET(FORM)="I":$GET(XBX(6,XBY,9999999.01,"I")),1:$GET(XBX(6,XBY,9999999.01)))

 +10       IF XBX=""

               QUIT "???"

 +11       QUIT XBX

 +12      ;

XBFUNC2.m