EDPFPER ;SLC/KCM - Lookup Persons at Facility ;2/28/12 08:33am
;;2.0;EMERGENCY DEPARTMENT;**6**;Feb 24, 2012;Build 200
;
MATCH(MATCH,PTYP) ; Return a matching list of providers
S MATCH=$$UP^XLFSTR(MATCH)
S MATCH=$TR(MATCH,"_"," ") ; underscore replaces space in flex widget
D XML^EDPX("<personType>"_PTYP_"</personType>")
I PTYP="C" D CLERK Q
I PTYP="N" D NURS Q
I "PR"[PTYP D PROV Q
Q
PROV ; match providers
N NM,PRV
S NM=$O(^VA(200,"AK.PROVIDER",MATCH),-1)
F S NM=$O(^VA(200,"AK.PROVIDER",NM)) Q:$E(NM,1,$L(MATCH))'=MATCH D
. S PRV=0 F S PRV=$O(^VA(200,"AK.PROVIDER",NM,PRV)) Q:'PRV D
.. I $$ALLOW(PRV,"P") D ADD(PRV,NM)
Q
NURS ; match nurses
N NM,NRS,EDPNURS
S EDPNURS=$$GET^XPAR("ALL","EDPF NURSE STAFF SCREEN")
S NM=$O(^VA(200,"B",MATCH),-1)
F S NM=$O(^VA(200,"B",NM)) Q:$E(NM,1,$L(MATCH))'=MATCH D
. S NRS=0 F S NRS=$O(^VA(200,"B",NM,NRS)) Q:'NRS D
.. I $$ALLOW(NRS,"N") D ADD(NRS,NM)
Q
CLERK ;
N NM,CLRK
S NM=$O(^VA(200,"B",MATCH),-1)
F S NM=$O(^VA(200,"B",NM)) Q:$E(NM,1,$L(MATCH))'=MATCH D
.S CLRK=0 F S CLRK=$O(^VA(200,"B",NM,CLRK)) Q:'CLRK D
..I $$ALLOW(CLRK,"C") D ADD(CLRK,NM)
Q
ADD(PER,NM) ; Add the person to the list of staff
N X,X0,TITLE
S X0=^VA(200,PER,0),TITLE=$P(X0,U,9)
S X("nm")=NM
S X("itl")=$P(X0,U,2)
I X("itl")="" S X("itl")=$E($P(NM,",",2))_$E(NM)
S X("duz")=PER
I TITLE S X("title")=$P($G(^DIC(3.1,TITLE,0)),U)
D XML^EDPX($$XMLA^EDPX("staff",.X))
Q
ALLOW(PER,ROLE) ; Screen when selecting persons
; PER is IEN for file 200, ROLE is P(rovider),R(esident), or N(urse)
; Expects EDPNURS to be defined for nurses (EDPF NURSE STAFF FILTER)
I '$$ACTIVE^XUSER(PER) Q 0
I ("PR"[ROLE),'$$PROVIDER^XUSER(PER) Q 0
Q:ROLE'="N" 1
;
I '$G(EDPNURS),'$D(^NURSF(210,"B",PER)) Q 0
I ($G(EDPNURS)=1),'$D(^XUSEC("ORELSE",PER)) Q 0
I ($G(EDPNURS)=2),'$D(^XUSEC("PSJ RNURSE",PER)) Q 0
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEDPFPER 1910 printed Dec 13, 2024@01:51:51 Page 2
EDPFPER ;SLC/KCM - Lookup Persons at Facility ;2/28/12 08:33am
+1 ;;2.0;EMERGENCY DEPARTMENT;**6**;Feb 24, 2012;Build 200
+2 ;
MATCH(MATCH,PTYP) ; Return a matching list of providers
+1 SET MATCH=$$UP^XLFSTR(MATCH)
+2 ; underscore replaces space in flex widget
SET MATCH=$TRANSLATE(MATCH,"_"," ")
+3 DO XML^EDPX("<personType>"_PTYP_"</personType>")
+4 IF PTYP="C"
DO CLERK
QUIT
+5 IF PTYP="N"
DO NURS
QUIT
+6 IF "PR"[PTYP
DO PROV
QUIT
+7 QUIT
PROV ; match providers
+1 NEW NM,PRV
+2 SET NM=$ORDER(^VA(200,"AK.PROVIDER",MATCH),-1)
+3 FOR
SET NM=$ORDER(^VA(200,"AK.PROVIDER",NM))
if $EXTRACT(NM,1,$LENGTH(MATCH))'=MATCH
QUIT
Begin DoDot:1
+4 SET PRV=0
FOR
SET PRV=$ORDER(^VA(200,"AK.PROVIDER",NM,PRV))
if 'PRV
QUIT
Begin DoDot:2
+5 IF $$ALLOW(PRV,"P")
DO ADD(PRV,NM)
End DoDot:2
End DoDot:1
+6 QUIT
NURS ; match nurses
+1 NEW NM,NRS,EDPNURS
+2 SET EDPNURS=$$GET^XPAR("ALL","EDPF NURSE STAFF SCREEN")
+3 SET NM=$ORDER(^VA(200,"B",MATCH),-1)
+4 FOR
SET NM=$ORDER(^VA(200,"B",NM))
if $EXTRACT(NM,1,$LENGTH(MATCH))'=MATCH
QUIT
Begin DoDot:1
+5 SET NRS=0
FOR
SET NRS=$ORDER(^VA(200,"B",NM,NRS))
if 'NRS
QUIT
Begin DoDot:2
+6 IF $$ALLOW(NRS,"N")
DO ADD(NRS,NM)
End DoDot:2
End DoDot:1
+7 QUIT
CLERK ;
+1 NEW NM,CLRK
+2 SET NM=$ORDER(^VA(200,"B",MATCH),-1)
+3 FOR
SET NM=$ORDER(^VA(200,"B",NM))
if $EXTRACT(NM,1,$LENGTH(MATCH))'=MATCH
QUIT
Begin DoDot:1
+4 SET CLRK=0
FOR
SET CLRK=$ORDER(^VA(200,"B",NM,CLRK))
if 'CLRK
QUIT
Begin DoDot:2
+5 IF $$ALLOW(CLRK,"C")
DO ADD(CLRK,NM)
End DoDot:2
End DoDot:1
+6 QUIT
ADD(PER,NM) ; Add the person to the list of staff
+1 NEW X,X0,TITLE
+2 SET X0=^VA(200,PER,0)
SET TITLE=$PIECE(X0,U,9)
+3 SET X("nm")=NM
+4 SET X("itl")=$PIECE(X0,U,2)
+5 IF X("itl")=""
SET X("itl")=$EXTRACT($PIECE(NM,",",2))_$EXTRACT(NM)
+6 SET X("duz")=PER
+7 IF TITLE
SET X("title")=$PIECE($GET(^DIC(3.1,TITLE,0)),U)
+8 DO XML^EDPX($$XMLA^EDPX("staff",.X))
+9 QUIT
ALLOW(PER,ROLE) ; Screen when selecting persons
+1 ; PER is IEN for file 200, ROLE is P(rovider),R(esident), or N(urse)
+2 ; Expects EDPNURS to be defined for nurses (EDPF NURSE STAFF FILTER)
+3 IF '$$ACTIVE^XUSER(PER)
QUIT 0
+4 IF ("PR"[ROLE)
IF '$$PROVIDER^XUSER(PER)
QUIT 0
+5 if ROLE'="N"
QUIT 1
+6 ;
+7 IF '$GET(EDPNURS)
IF '$DATA(^NURSF(210,"B",PER))
QUIT 0
+8 IF ($GET(EDPNURS)=1)
IF '$DATA(^XUSEC("ORELSE",PER))
QUIT 0
+9 IF ($GET(EDPNURS)=2)
IF '$DATA(^XUSEC("PSJ RNURSE",PER))
QUIT 0
+10 QUIT 1
