IBDF18B.m

IBDF18B ;ALB/AAS - ENCOUNTER FORM - utilities for PCE ;04-OCT-94

 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997

 ;

GETPRO(CLINIC,ARY) ; -- returns list of providers specified for a clinic

 ; -- input  CLINIC = pointer to hospital location file for clinic

 ;              ARY = name of array to return list in

 ;

 ; -- output  The format of the returned array is as follows

 ;         @ARY@(0) = count of array element (0 of nothing found)

 ;         @ARY@(1) = pointer to 200^provider name from 200 (default provider if indicated)

 ;         @ARY@(2) = pointer to 200^provider name from 200

 ;

 N I,J,X,Y,IBX,IBQUIT,COUNT,IBC,ERR,CT

 S (CT,COUNT,IBQUIT)=0

 ;

 S @ARY@(0)=""

 I $G(CLINIC)="" G GETPROQ

 I $G(^SC(CLINIC,0))="" G GETPROQ

 S ERR="IBDERR"

 ;

 ; -- don't use PCMM providers checked

 I $P($G(^SD(409.95,+$O(^SD(409.95,"B",CLINIC,0)),0)),"^",10) G CLIN

 ;

 ; -- get providers from PCMM teams, if available

 I $L($T(PRCL^SCAPMC)) S X=$$PRCL^SCAPMC(.CLINIC,"","","","",ARY,ERR) I @ARY@(0)>0 D

 .K @ARY@("SCPR")

 .F I=1:1:@ARY@(0) I '$$SCREEN^IBDFDE10(+@ARY@(I)) K @ARY@(I) S CT=CT+1

 .S @ARY@(0)=@ARY@(0)-CT

 I @ARY@(0)>0 G GETPROQ

 ;

CLIN I $O(^SC(CLINIC,"PR",0))="" G GETPROQ

 ;

 ; -- default provider should always be listed first

 S IBX=$O(^SC("ADPR",CLINIC,0)) I IBX D

 .S X=$G(^SC(CLINIC,"PR",IBX,0))

 .D INCPR(+X)

 ;

 ; -- get rest of list of providers

 S IBX=0 F  S IBX=$O(^SC(CLINIC,"PR",IBX)) Q:'IBX  I IBX D

 .S X=$G(^SC(CLINIC,"PR",IBX,0))

 .D INCPR(+X)

 S @ARY@(0)=COUNT

 ;

GETPROQ Q

 ;

INCPR(X) ; -- increment counter and set provider array

 Q:'X!($G(^VA(200,+X,0))="")

 Q:$D(IBX(+X))  ; -- already set

 S COUNT=COUNT+1,@ARY@(COUNT)=+X_"^"_$P(^VA(200,+X,0),"^")

 S IBX(+X)=""

 Q

 ;

TEST K ALAN D GETPRO(25,"ALAN")

 X "ZW ALAN"

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IBDF18B   1810     printed  Feb 19, 2025@00:17:18                                                                                                                                                                                                     Page 2

IBDF18B   ;ALB/AAS - ENCOUNTER FORM - utilities for PCE ;04-OCT-94

 +1       ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997

 +2       ;

GETPRO(CLINIC,ARY) ; -- returns list of providers specified for a clinic

 +1       ; -- input  CLINIC = pointer to hospital location file for clinic

 +2       ;              ARY = name of array to return list in

 +3       ;

 +4       ; -- output  The format of the returned array is as follows

 +5       ;         @ARY@(0) = count of array element (0 of nothing found)

 +6       ;         @ARY@(1) = pointer to 200^provider name from 200 (default provider if indicated)

 +7       ;         @ARY@(2) = pointer to 200^provider name from 200

 +8       ;

 +9        NEW I,J,X,Y,IBX,IBQUIT,COUNT,IBC,ERR,CT

 +10       SET (CT,COUNT,IBQUIT)=0

 +11      ;

 +12       SET @ARY@(0)=""

 +13       IF $GET(CLINIC)=""

               GOTO GETPROQ

 +14       IF $GET(^SC(CLINIC,0))=""

               GOTO GETPROQ

 +15       SET ERR="IBDERR"

 +16      ;

 +17      ; -- don't use PCMM providers checked

 +18       IF $PIECE($GET(^SD(409.95,+$ORDER(^SD(409.95,"B",CLINIC,0)),0)),"^",10)

               GOTO CLIN

 +19      ;

 +20      ; -- get providers from PCMM teams, if available

 +21       IF $LENGTH($TEXT(PRCL^SCAPMC))

               SET X=$$PRCL^SCAPMC(.CLINIC,"","","","",ARY,ERR)

               IF @ARY@(0)>0

                   Begin DoDot:1

 +22                   KILL @ARY@("SCPR")

 +23                   FOR I=1:1:@ARY@(0)

                           IF '$$SCREEN^IBDFDE10(+@ARY@(I))

                               KILL @ARY@(I)

                               SET CT=CT+1

 +24                   SET @ARY@(0)=@ARY@(0)-CT

                   End DoDot:1

 +25       IF @ARY@(0)>0

               GOTO GETPROQ

 +26      ;

CLIN       IF $ORDER(^SC(CLINIC,"PR",0))=""

               GOTO GETPROQ

 +1       ;

 +2       ; -- default provider should always be listed first

 +3        SET IBX=$ORDER(^SC("ADPR",CLINIC,0))

           IF IBX

               Begin DoDot:1

 +4                SET X=$GET(^SC(CLINIC,"PR",IBX,0))

 +5                DO INCPR(+X)

               End DoDot:1

 +6       ;

 +7       ; -- get rest of list of providers

 +8        SET IBX=0

           FOR 

               SET IBX=$ORDER(^SC(CLINIC,"PR",IBX))

               if 'IBX

                   QUIT 

               IF IBX

                   Begin DoDot:1

 +9                    SET X=$GET(^SC(CLINIC,"PR",IBX,0))

 +10                   DO INCPR(+X)

                   End DoDot:1

 +11       SET @ARY@(0)=COUNT

 +12      ;

GETPROQ    QUIT 

 +1       ;

INCPR(X)  ; -- increment counter and set provider array

 +1        if 'X!($GET(^VA(200,+X,0))="")

               QUIT 

 +2       ; -- already set

           if $DATA(IBX(+X))

               QUIT 

 +3        SET COUNT=COUNT+1

           SET @ARY@(COUNT)=+X_"^"_$PIECE(^VA(200,+X,0),"^")

 +4        SET IBX(+X)=""

 +5        QUIT 

 +6       ;

TEST       KILL ALAN

           DO GETPRO(25,"ALAN")

 +1        XECUTE "ZW ALAN"

 +2        QUIT