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 ;
