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 ---[H[J[2J[HIBDF18B 1810 printed Dec 13, 2024@02:50:52 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
