- BEHOPTPC ;MSC/IND/DKM - RPC calls for provider information ;16-Apr-2013 14:35;DU
- ;;1.1;BEH COMPONENTS;**004004,004009**;Mar 20, 2007
- ;=================================================================
- USESD() Q $G(DUZ("AG"))'="I"
- ; Get the primary provider
- OUTPTPR(DFN) ;EP
- Q:$$USESD $$OUTPTPR^SDUTL3(DFN)
- N PCP
- S PCP=$$GET1^DIQ(9000001,DFN,.14,"I")
- Q $S(PCP:PCP_U_$P(^VA(200,PCP,0),U),1:"")
- ; Get team
- OUTPTTM(DFN) ;EP
- Q:$$USESD $$OUTPTTM^SDUTL3(DFN)
- N TM
- S TM=$O(^BSDPCT("AB",+$$OUTPTPR(DFN),0))
- Q $S(TM:TM_U_$$GET1^DIQ(9009017.5,TM,.01),1:"")
- ; Return Primary Care Detail information
- DETAIL(DATA,DFN) ;EP
- I $$USESD D
- .N I,X
- .S X=$$OUTPTTM^SDUTL3(DFN,DT),I=0
- .I X>0 D
- ..D ADDDET($P(X,U,2),"Primary Care Team")
- ..D ADDDET($P($G(^SCTM(404.51,+X,0)),U,2),"Phone")
- .E D ADDDET("No Primary Care Team Assigned.")
- .D ADDPRV("Primary Care Provider",+$$OUTPTPR^SDUTL3(DFN,DT))
- .D ADDPRV("Associate Provider",+$$OUTPTAP^SDUTL3(DFN,DT))
- .D ADDPRV("Attending Physician",+$G(^DPT(DFN,.1041)),1)
- E D
- .N I,X,BDPQ,BDPTYPE,BDPCOUNT,BDPRIEN,BDPTYPNM,BDPCPRV
- .S I=0
- .D ADDDET("**CURRENT DESIGNATED PROVIDERS - BY PROVIDER CATEGORY TYPE**")
- .I '$D(^BDPRECN("AA",DFN)) D ADDDET("**--NO EXISTING DESIGNATED PROVIDERS--**") Q
- .S BDPQ=0,BDPTYPE="",BDPCOUNT=0
- .F S BDPTYPE=$O(^BDPRECN("AA",DFN,BDPTYPE)) Q:BDPTYPE="" D
- ..S BDPCOUNT=BDPCOUNT+1,BDPRIEN=""
- ..S BDPTYPNM=$P(^BDPTCAT(BDPTYPE,0),U) ;Type Print
- ..F S BDPRIEN=$O(^BDPRECN("AA",DFN,BDPTYPE,BDPRIEN)) Q:BDPRIEN'=+BDPRIEN D
- ...S BDPCPRV=+$P($G(^BDPRECN(BDPRIEN,0)),U,3)
- ...Q:'+BDPCPRV
- ...;Current Provider IEN
- ...;S BDPCPRVP=$S(BDPCPRV:$P($G(^VA(200,BDPCPRV,0)),U),1:"<None Currently Assigned>")
- ...S BDPCPRVP=$P($G(^VA(200,BDPCPRV,0)),U)
- ...D ADDDET(BDPCOUNT_" "_$$LJ^XLFSTR($E(BDPTYPNM,1,30),30)_": "_$$LJ^XLFSTR($E(BDPCPRVP,1,35),45))
- Q
- ADDDET(TXT,LBL) ;
- Q:'$L($G(TXT))
- S:$D(LBL) TXT=$$RJ^XLFSTR(LBL,21)_": "_TXT
- S DATA(I)=TXT,I=I+1
- Q
- ADDPRV(TYP,PRV,FLG) ;
- D ADDDET(" ")
- I $D(^VA(200,PRV,0)) D
- .N X
- .D ADDDET($P(^VA(200,PRV,0),U),TYP)
- .S X=$G(^VA(200,PRV,.13))
- .D ADDDET($P(X,U,7),"Analog Pager")
- .D ADDDET($P(X,U,8),"Digital Pager")
- .D ADDDET($P(X,U,2),"Office Phone")
- E D:'$G(FLG) ADDDET("No "_TYP_" Assigned.")
- Q
- ; Find all providers on the team associated with the primary provider
- TEAM(BEHODUZ) ;EP
- N BEHOX,BEHOY,BEHOTM,BEHOCT
- K ^TMP("ORIHS",$J)
- ;BEHOX is the team of the primary provider
- S BEHOCT=0,BEHOX=$O(^BSDPCT("AB",BEHODUZ,0)),BEHOY=0
- Q:'BEHOX
- F S BEHOY=$O(^BSDPCT(BEHOX,1,BEHOY)) Q:BEHOY="" D
- .S BEHOTM=$P($G(^BSDPCT(BEHOX,1,BEHOY,0)),U)
- .S:BEHOTM'="" ^TMP("ORIHS",$J,BEHOTM)=""
- Q
- GETBDP(RET,DFN) ;RPC to get all designated providers for a patient
- N ARRAY,CNT
- D ALLDP^BDPAPI(DFN,"",.ARRAY)
- S CNT=0
- S TYP="" F S TYP=$O(ARRAY(TYP)) Q:TYP="" D
- .S TXT=$G(ARRAY(TYP))
- .I TXT'="" D
- ..S CNT=CNT+1
- ..S RET(CNT)=TYP_U_TXT
- Q
- SETBDP(RET,DFN,TYPE,PROV) ;RPC to add/edit/delete a provider for a category
- D AEDAP^BDPAPI(DFN,PROV,TYPE,.RET)
- Q
- GETCATS(LIST) ;Return the list of categories
- N CAT,CNT
- S CNT=0
- S CAT="" F S CAT=$O(^BDPTCAT("B",CAT)) Q:CAT="" D
- .S CNT=CNT+1
- .S LIST(CNT)=CAT
- Q
- BEHOPTPC ;MSC/IND/DKM - RPC calls for provider information ;16-Apr-2013 14:35;DU
- +1 ;;1.1;BEH COMPONENTS;**004004,004009**;Mar 20, 2007
- +2 ;=================================================================
- USESD() QUIT $GET(DUZ("AG"))'="I"
- +1 ; Get the primary provider
- OUTPTPR(DFN) ;EP
- +1 IF $$USESD
- QUIT $$OUTPTPR^SDUTL3(DFN)
- +2 NEW PCP
- +3 SET PCP=$$GET1^DIQ(9000001,DFN,.14,"I")
- +4 QUIT $SELECT(PCP:PCP_U_$PIECE(^VA(200,PCP,0),U),1:"")
- +5 ; Get team
- OUTPTTM(DFN) ;EP
- +1 IF $$USESD
- QUIT $$OUTPTTM^SDUTL3(DFN)
- +2 NEW TM
- +3 SET TM=$ORDER(^BSDPCT("AB",+$$OUTPTPR(DFN),0))
- +4 QUIT $SELECT(TM:TM_U_$$GET1^DIQ(9009017.5,TM,.01),1:"")
- +5 ; Return Primary Care Detail information
- DETAIL(DATA,DFN) ;EP
- +1 IF $$USESD
- Begin DoDot:1
- +2 NEW I,X
- +3 SET X=$$OUTPTTM^SDUTL3(DFN,DT)
- SET I=0
- +4 IF X>0
- Begin DoDot:2
- +5 DO ADDDET($PIECE(X,U,2),"Primary Care Team")
- +6 DO ADDDET($PIECE($GET(^SCTM(404.51,+X,0)),U,2),"Phone")
- End DoDot:2
- +7 IF '$TEST
- DO ADDDET("No Primary Care Team Assigned.")
- +8 DO ADDPRV("Primary Care Provider",+$$OUTPTPR^SDUTL3(DFN,DT))
- +9 DO ADDPRV("Associate Provider",+$$OUTPTAP^SDUTL3(DFN,DT))
- +10 DO ADDPRV("Attending Physician",+$GET(^DPT(DFN,.1041)),1)
- End DoDot:1
- +11 IF '$TEST
- Begin DoDot:1
- +12 NEW I,X,BDPQ,BDPTYPE,BDPCOUNT,BDPRIEN,BDPTYPNM,BDPCPRV
- +13 SET I=0
- +14 DO ADDDET("**CURRENT DESIGNATED PROVIDERS - BY PROVIDER CATEGORY TYPE**")
- +15 IF '$DATA(^BDPRECN("AA",DFN))
- DO ADDDET("**--NO EXISTING DESIGNATED PROVIDERS--**")
- QUIT
- +16 SET BDPQ=0
- SET BDPTYPE=""
- SET BDPCOUNT=0
- +17 FOR
- SET BDPTYPE=$ORDER(^BDPRECN("AA",DFN,BDPTYPE))
- IF BDPTYPE=""
- QUIT
- Begin DoDot:2
- +18 SET BDPCOUNT=BDPCOUNT+1
- SET BDPRIEN=""
- +19 ;Type Print
- SET BDPTYPNM=$PIECE(^BDPTCAT(BDPTYPE,0),U)
- +20 FOR
- SET BDPRIEN=$ORDER(^BDPRECN("AA",DFN,BDPTYPE,BDPRIEN))
- IF BDPRIEN'=+BDPRIEN
- QUIT
- Begin DoDot:3
- +21 SET BDPCPRV=+$PIECE($GET(^BDPRECN(BDPRIEN,0)),U,3)
- +22 IF '+BDPCPRV
- QUIT
- +23 ;Current Provider IEN
- +24 ;S BDPCPRVP=$S(BDPCPRV:$P($G(^VA(200,BDPCPRV,0)),U),1:"<None Currently Assigned>")
- +25 SET BDPCPRVP=$PIECE($GET(^VA(200,BDPCPRV,0)),U)
- +26 DO ADDDET(BDPCOUNT_" "_$$LJ^XLFSTR($EXTRACT(BDPTYPNM,1,30),30)_": "_$$LJ^XLFSTR($EXTRACT(BDPCPRVP,1,35),45))
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +27 QUIT
- ADDDET(TXT,LBL) ;
- +1 IF '$LENGTH($GET(TXT))
- QUIT
- +2 IF $DATA(LBL)
- SET TXT=$$RJ^XLFSTR(LBL,21)_": "_TXT
- +3 SET DATA(I)=TXT
- SET I=I+1
- +4 QUIT
- ADDPRV(TYP,PRV,FLG) ;
- +1 DO ADDDET(" ")
- +2 IF $DATA(^VA(200,PRV,0))
- Begin DoDot:1
- +3 NEW X
- +4 DO ADDDET($PIECE(^VA(200,PRV,0),U),TYP)
- +5 SET X=$GET(^VA(200,PRV,.13))
- +6 DO ADDDET($PIECE(X,U,7),"Analog Pager")
- +7 DO ADDDET($PIECE(X,U,8),"Digital Pager")
- +8 DO ADDDET($PIECE(X,U,2),"Office Phone")
- End DoDot:1
- +9 IF '$TEST
- IF '$GET(FLG)
- DO ADDDET("No "_TYP_" Assigned.")
- +10 QUIT
- +11 ; Find all providers on the team associated with the primary provider
- TEAM(BEHODUZ) ;EP
- +1 NEW BEHOX,BEHOY,BEHOTM,BEHOCT
- +2 KILL ^TMP("ORIHS",$JOB)
- +3 ;BEHOX is the team of the primary provider
- +4 SET BEHOCT=0
- SET BEHOX=$ORDER(^BSDPCT("AB",BEHODUZ,0))
- SET BEHOY=0
- +5 IF 'BEHOX
- QUIT
- +6 FOR
- SET BEHOY=$ORDER(^BSDPCT(BEHOX,1,BEHOY))
- IF BEHOY=""
- QUIT
- Begin DoDot:1
- +7 SET BEHOTM=$PIECE($GET(^BSDPCT(BEHOX,1,BEHOY,0)),U)
- +8 IF BEHOTM'=""
- SET ^TMP("ORIHS",$JOB,BEHOTM)=""
- End DoDot:1
- +9 QUIT
- GETBDP(RET,DFN) ;RPC to get all designated providers for a patient
- +1 NEW ARRAY,CNT
- +2 DO ALLDP^BDPAPI(DFN,"",.ARRAY)
- +3 SET CNT=0
- +4 SET TYP=""
- FOR
- SET TYP=$ORDER(ARRAY(TYP))
- IF TYP=""
- QUIT
- Begin DoDot:1
- +5 SET TXT=$GET(ARRAY(TYP))
- +6 IF TXT'=""
- Begin DoDot:2
- +7 SET CNT=CNT+1
- +8 SET RET(CNT)=TYP_U_TXT
- End DoDot:2
- End DoDot:1
- +9 QUIT
- SETBDP(RET,DFN,TYPE,PROV) ;RPC to add/edit/delete a provider for a category
- +1 DO AEDAP^BDPAPI(DFN,PROV,TYPE,.RET)
- +2 QUIT
- GETCATS(LIST) ;Return the list of categories
- +1 NEW CAT,CNT
- +2 SET CNT=0
- +3 SET CAT=""
- FOR
- SET CAT=$ORDER(^BDPTCAT("B",CAT))
- IF CAT=""
- QUIT
- Begin DoDot:1
- +4 SET CNT=CNT+1
- +5 SET LIST(CNT)=CAT
- End DoDot:1
- +6 QUIT