- 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 Jan 18, 2025@03:32: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 ;