PXRRPRPL ;ISL/PKR - Build the Provider list ;01/30/2017
;;1.0;PCE PATIENT CARE ENCOUNTER;**10,12,211**;Aug 12, 1996;Build 454
;Build the Provider list based upon the Provider selection criteria.
;
;==========================================
PRV ;Build a list of selected providers.
N X,Y
K DTOUT,DUOUT
S NPL=0
S DIC=200
S DIC(0)="AEQMZ"
S DIC("A")="Select PROVIDER: "
;As of April 1996 a determination has been made not to use the provider
;key screen. It has just been commented out because there is a
;possibility it may be used in the future.
;S DIC("S")="I $D(^VA(200,""AK.PROVIDER"",$P($G(^VA(200,+Y,0)),U)))"
W !
NPRO I NPL'<1 S DIC("A")="Select another PROVIDER: "
D ^DIC
I X=(U_U) S DTOUT=1
I $D(DTOUT) Q
I +Y'=-1 D G NPRO
. S NPL=NPL+1
. S PXRRPRPL(NPL)=$P(Y,U,2)_U_$P(Y,U,1)
E K DIC
I (NPL=0)&($D(DIRUT)!$D(DUOUT)) Q
I $D(DUOUT) G PRV
I (NPL=0)&(+Y=-1) W !,"You must select a provider!" G PRV
;
;Sort the provider list into ascending order.
S NPL=$$SORT^PXRRUTIL(NPL,"PXRRPRPL")
Q
;
;==========================================
TEAM ;Build a list of selected providers by CPRS Team.
;DBIA #1489 covers access to file #100.21.
N IEN,PRVDUZ,PRVNAME,X,Y
K DTOUT,DUOUT
S NPL=0
S DIC=100.21
S DIC(0)="AEQMZ"
S DIC("A")="Select CPRS Team (OE/RR List): "
W !
NTEAM I NPL'<1 S DIC("A")="Select another CPRS Team (OE/RR List): "
D ^DIC
I X=(U_U) S DTOUT=1
I $D(DTOUT) Q
I +Y'=-1 D G NTEAM
. S IEN=+$P(Y,U,1)
. I $P($G(^OR(100.21,IEN,1,0)),U,4)'>0 D G NTEAM
.. W !,"There are no providers on this CPRS Team (OE/RR List)!"
. S PRVDUZ=0
. F S PRVDUZ=$O(^OR(100.21,IEN,1,PRVDUZ)) Q:PRVDUZ="" D
.. S PRVNAME=$$GET1^DIQ(200,PRVDUZ,.01)
.. S NPL=NPL+1
.. S PXRRPRPL(NPL)=PRVNAME_U_PRVDUZ
E K DIC
I (NPL=0)&($D(DIRUT)!$D(DUOUT)) Q
I $D(DUOUT) G TEAM
I (NPL=0)&(+Y=-1) W !,"You must select a CPRS Team (OE/RR List)!" G TEAM
;
;Sort the provider list into ascending order.
S NPL=$$SORT^PXRRUTIL(NPL,"PXRRPRPL")
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRRPRPL 2038 printed Nov 22, 2024@17:41:11 Page 2
PXRRPRPL ;ISL/PKR - Build the Provider list ;01/30/2017
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**10,12,211**;Aug 12, 1996;Build 454
+2 ;Build the Provider list based upon the Provider selection criteria.
+3 ;
+4 ;==========================================
PRV ;Build a list of selected providers.
+1 NEW X,Y
+2 KILL DTOUT,DUOUT
+3 SET NPL=0
+4 SET DIC=200
+5 SET DIC(0)="AEQMZ"
+6 SET DIC("A")="Select PROVIDER: "
+7 ;As of April 1996 a determination has been made not to use the provider
+8 ;key screen. It has just been commented out because there is a
+9 ;possibility it may be used in the future.
+10 ;S DIC("S")="I $D(^VA(200,""AK.PROVIDER"",$P($G(^VA(200,+Y,0)),U)))"
+11 WRITE !
NPRO IF NPL'<1
SET DIC("A")="Select another PROVIDER: "
+1 DO ^DIC
+2 IF X=(U_U)
SET DTOUT=1
+3 IF $DATA(DTOUT)
QUIT
+4 IF +Y'=-1
Begin DoDot:1
+5 SET NPL=NPL+1
+6 SET PXRRPRPL(NPL)=$PIECE(Y,U,2)_U_$PIECE(Y,U,1)
End DoDot:1
GOTO NPRO
+7 IF '$TEST
KILL DIC
+8 IF (NPL=0)&($DATA(DIRUT)!$DATA(DUOUT))
QUIT
+9 IF $DATA(DUOUT)
GOTO PRV
+10 IF (NPL=0)&(+Y=-1)
WRITE !,"You must select a provider!"
GOTO PRV
+11 ;
+12 ;Sort the provider list into ascending order.
+13 SET NPL=$$SORT^PXRRUTIL(NPL,"PXRRPRPL")
+14 QUIT
+15 ;
+16 ;==========================================
TEAM ;Build a list of selected providers by CPRS Team.
+1 ;DBIA #1489 covers access to file #100.21.
+2 NEW IEN,PRVDUZ,PRVNAME,X,Y
+3 KILL DTOUT,DUOUT
+4 SET NPL=0
+5 SET DIC=100.21
+6 SET DIC(0)="AEQMZ"
+7 SET DIC("A")="Select CPRS Team (OE/RR List): "
+8 WRITE !
NTEAM IF NPL'<1
SET DIC("A")="Select another CPRS Team (OE/RR List): "
+1 DO ^DIC
+2 IF X=(U_U)
SET DTOUT=1
+3 IF $DATA(DTOUT)
QUIT
+4 IF +Y'=-1
Begin DoDot:1
+5 SET IEN=+$PIECE(Y,U,1)
+6 IF $PIECE($GET(^OR(100.21,IEN,1,0)),U,4)'>0
Begin DoDot:2
+7 WRITE !,"There are no providers on this CPRS Team (OE/RR List)!"
End DoDot:2
GOTO NTEAM
+8 SET PRVDUZ=0
+9 FOR
SET PRVDUZ=$ORDER(^OR(100.21,IEN,1,PRVDUZ))
if PRVDUZ=""
QUIT
Begin DoDot:2
+10 SET PRVNAME=$$GET1^DIQ(200,PRVDUZ,.01)
+11 SET NPL=NPL+1
+12 SET PXRRPRPL(NPL)=PRVNAME_U_PRVDUZ
End DoDot:2
End DoDot:1
GOTO NTEAM
+13 IF '$TEST
KILL DIC
+14 IF (NPL=0)&($DATA(DIRUT)!$DATA(DUOUT))
QUIT
+15 IF $DATA(DUOUT)
GOTO TEAM
+16 IF (NPL=0)&(+Y=-1)
WRITE !,"You must select a CPRS Team (OE/RR List)!"
GOTO TEAM
+17 ;
+18 ;Sort the provider list into ascending order.
+19 SET NPL=$$SORT^PXRRUTIL(NPL,"PXRRPRPL")
+20 QUIT
+21 ;
