BSDU3.m

BSDU3 ; IHS/ANMC/LJF - TEAM INFO UTILITIES ; 

 ;;5.3;PIMS;;APR 26, 2002

 ;

PROV(TEAM,DATES,LIST) ;EP; returns array in LIST of providers tied to team

 ;Only called if PCMM is used!!!!!!!!!!!!!

 ; TEAM=team ien

 ; DATES("BEGIN")=earliest date for provider on team

 ; DATES("END")=lastest date for provider

 ; DATES("INCL")=1 to get only those on team throughout date range

 ;              =0 to get those on team sometime during date range

 N OKAY,XLIST,YLIST,POS,PRV,PLIST

 S LIST="^TMP(""SCRP"",$J,""LIST"")"

 K XLIST,@LIST

 ;

 ; find positions for team

 S OKAY=$$TPTM^SCAPMC(TEAM,.DATES,"","","XLIST","ERROR")

 ;

 ; loop thru positions to find providers

 S POS=0 F  S POS=$O(XLIST("SCTP",TEAM,POS)) Q:'POS  D

 . S POS0=$G(^SCTM(404.57,POS,0)) Q:'$L(POS0)

 . ;

 . ; find providers for position during date range

 . K YLIST S OKAY=$$PRTP^SCAPMC(POS,.SCDT,"YLIST","ERROR",1,0)

 . ;

 . ; loop thru providers found

 . S PRV=0 F  S PRV=$O(YLIST(PRV)) Q:'PRV  D

 .. S @LIST@(0)=$G(@LIST@(0))+1

 .. S @LIST@(@LIST@(0))=YLIST(PRV)

 ;

 Q LIST

 ;

CLINICS(PROV,LIST) ;EP; returns array of clinics for this provider

 ; PROV=provider ien; LIST returns as array

 NEW X

 S X=0 F  S X=$O(^SC("AIHSDPR",PROV,X)) Q:'X  D

 . S Y=$O(^SC("AIHSDPR",PROV,X,0)) Q:'Y  ;quit if bad xref

 . Q:$G(^SC("AIHSDPR",PROV,X,Y))'=1      ;quit if not default provider

 . S LIST(X)=""

 Q

BSDU3     ; IHS/ANMC/LJF - TEAM INFO UTILITIES ; 

 +1       ;;5.3;PIMS;;APR 26, 2002

 +2       ;

PROV(TEAM,DATES,LIST) ;EP; returns array in LIST of providers tied to team

 +1       ;Only called if PCMM is used!!!!!!!!!!!!!

 +2       ; TEAM=team ien

 +3       ; DATES("BEGIN")=earliest date for provider on team

 +4       ; DATES("END")=lastest date for provider

 +5       ; DATES("INCL")=1 to get only those on team throughout date range

 +6       ;              =0 to get those on team sometime during date range

 +7        NEW OKAY,XLIST,YLIST,POS,PRV,PLIST

 +8        SET LIST="^TMP(""SCRP"",$J,""LIST"")"

 +9        KILL XLIST,@LIST

 +10      ;

 +11      ; find positions for team

 +12       SET OKAY=$$TPTM^SCAPMC(TEAM,.DATES,"","","XLIST","ERROR")

 +13      ;

 +14      ; loop thru positions to find providers

 +15       SET POS=0

           FOR 

               SET POS=$ORDER(XLIST("SCTP",TEAM,POS))

               IF 'POS

                   QUIT 

               Begin DoDot:1

 +16               SET POS0=$GET(^SCTM(404.57,POS,0))

                   IF '$LENGTH(POS0)

                       QUIT 

 +17      ;

 +18      ; find providers for position during date range

 +19               KILL YLIST

                   SET OKAY=$$PRTP^SCAPMC(POS,.SCDT,"YLIST","ERROR",1,0)

 +20      ;

 +21      ; loop thru providers found

 +22               SET PRV=0

                   FOR 

                       SET PRV=$ORDER(YLIST(PRV))

                       IF 'PRV

                           QUIT 

                       Begin DoDot:2

 +23                       SET @LIST@(0)=$GET(@LIST@(0))+1

 +24                       SET @LIST@(@LIST@(0))=YLIST(PRV)

                       End DoDot:2

               End DoDot:1

 +25      ;

 +26       QUIT LIST

 +27      ;

CLINICS(PROV,LIST) ;EP; returns array of clinics for this provider

 +1       ; PROV=provider ien; LIST returns as array

 +2        NEW X

 +3        SET X=0

           FOR 

               SET X=$ORDER(^SC("AIHSDPR",PROV,X))

               IF 'X

                   QUIT 

               Begin DoDot:1

 +4       ;quit if bad xref

                   SET Y=$ORDER(^SC("AIHSDPR",PROV,X,0))

                   IF 'Y

                       QUIT 

 +5       ;quit if not default provider

                   IF $GET(^SC("AIHSDPR",PROV,X,Y))'=1

                       QUIT 

 +6                SET LIST(X)=""

               End DoDot:1

 +7        QUIT