DGSDUTL ;ALB/PHH,RMM - DG/SD API UTILITIES ;3/4/2004 10:03
;;5.3;Registration;**568**;AUG 13, 1993
;
Q
PCTEAM(DFN,DATE,ASSTYPE) ; Get Primary Care Team
; DFN - IEN of patient file (#2)
; DATE - Date of interest (Default=DT)
; ASSTYPE - Assignment Type (Default=1 for PC Team)
;
N RETVAL,ACTDT,SCTM,SCPTTMA,INACTDT
S RETVAL=0
Q:'$G(DFN) RETVAL
S DATE=$G(DATE,DT),ASSTYPE=$G(ASSTYPE,1)
;
; Returns pointer to file #404.51 if it exists, 0 if not
S ACTDT=+$O(^SCPT(404.42,"APCTM",+DFN,+ASSTYPE,(DATE+.000001)),-1)
S SCTM=$O(^SCPT(404.42,"APCTM",+DFN,+ASSTYPE,+ACTDT,0))
S SCPTTMA=$O(^SCPT(404.42,"APCTM",+DFN,+ASSTYPE,+ACTDT,+SCTM,0))
S INACTDT=$P($G(^SCPT(404.42,+SCPTTMA,0)),U,9)
S RETVAL=$S('INACTDT:+SCTM,(INACTDT'<DATE):+SCTM,1:0)
S RETVAL=$S('$G(RETVAL):"",1:RETVAL_U_$P($G(^SCTM(404.51,+RETVAL,0)),U,1))
Q RETVAL
;
PCPRACT(DFN,DATE,PCROLE) ; Get PC Practitioner
; DFN - Pointer to Patient file
; DATE - Date of interest
; PCROLE - Practitioner Position where '1' = PC provider
; '2' = PC attending
; '3' = PC associate provider
; Returned: Pointer to file #200 ^ External value of name
; or, if error or none defined, returns a 0 or null
;
N RETVAL,SCOK,SCTP,ACTDT,TPLP,TPDALP,INACTDT,PCAP
S RETVAL=0
Q:'$G(DFN) RETVAL
S DATE=$G(DATE,DT),PCROLE=$G(PCROLE,1)
;
; Returns pointer to file #404.57 if it exists, 0 if not
S SCOK=1,SCTP=0
S ACTDT=+$O(^SCPT(404.43,"APCPOS",+DFN,+PCROLE,(DATE+.000001)),-1)
F TPLP=0:0 S TPLP=$O(^SCPT(404.43,"APCPOS",+DFN,+PCROLE,+ACTDT,TPLP)) Q:TPLP=""!(SCTP=-1) D
.F TPDALP=0:0 S TPDALP=$O(^SCPT(404.43,"APCPOS",+DFN,+PCROLE,+ACTDT,TPLP,TPDALP)) Q:TPDALP="" D Q:SCTP=-1
..S INACTDT=$P($G(^SCPT(404.43,+TPDALP,0)),U,4)
..;
..; Error if it's already an active date
..I 'INACTDT S SCTP=$S(SCTP>0:-1,1:TPLP) Q
..I INACTDT'<DATE S SCTP=$S(SCTP>0:-1,1:TPLP)
S RETVAL=+SCTP
S RETVAL=$S('$G(RETVAL):"",RETVAL=-1:"",1:RETVAL_U_$P($G(^SCTM(404.57,+RETVAL,0)),U,1))
;
S SCTP=+RETVAL,PCAP=+$G(PCROLE,1),PCAP=$S(PCAP=0:1,PCAP>3:1,1:PCAP)
S PCROLE=$S(PCROLE=0:1,PCROLE>2:1,1:PCROLE)
S RETVAL=$S('SCTP:"",1:$$PCPROV^SCAPMCU3(SCTP,.DATE,PCAP))
Q RETVAL
;
DATE ; Get Begin Date and End Date
S:$D(%DT(0)) SDT0=%DT(0) S:$D(SDT00) %DT=SDT00 S POP=0 K BEGDATE,ENDDATE W !!,"**** Date Range Selection ****"
W ! S %DT=$S($D(SDT00):SDT00,1:"AE"),%DT("A")=" Beginning DATE : " D ^%DT S:Y<0 POP=1 G:Y<0 EX S (BEGDATE,SDBD)=Y
W ! S %DT="AE",%DT("A")=" Ending DATE : " D ^%DT K %DT S:Y<0 POP=1 G:Y<0 EX G:Y<SDBD HELP W ! S (ENDDATE,SDED)=Y
EX K SDT0,SDT00 Q
HELP W "??",!?5,"Ending date must not be before beginning date" S:$D(SDT0) %DT(0)=SDT0 G DATE
;
TDATA(DFN,VALMCNT,SDATE,SDPRT,SDCOL) ;
;Team information - gather, format and optionally print.
;
; Input: DFN=patient ifn
; VALMCNT=variable to return number of lines (pass by reference)
; SDATE=effective date (optional)
; SDPRT=print flag, 'P' for PC info only, 'A' for all (optional)
; SDCOL=column to print in conjunction with SDPRT flag (optional)
;
Q:DFN'>0
N SDI,SDATE,SDLIST,SDX,SDLN,SDY,SDPH,SDTEAM,SDPTA,SDII,SDIII,SDZ
N SDTM,SDTMN,SDPO,SDPON,SDPR,SDPRN,PAGER,PHONE
;
F SDI="SDPLIST","SDTEMP" K ^TMP(SDI,$J)
S SDCOL=+$G(SDCOL),SDATE=$G(SDATE) S:SDATE<1 SDATE=DT
F SDI="BEGIN","END" S SDATE(SDI)=SDATE
S SDATE="SDATE",SDLIST="^TMP(""SDPLIST"",$J)",SDLN=2
S SDI=$$GETALL^SCAPMCA(DFN,.SDATE,SDLIST)
;
;PC Team
S SDI=0 F S SDI=$O(^TMP("SDPLIST",$J,DFN,"PCTM",SDI)) Q:'SDI D
.S SDX=$G(^TMP("SDPLIST",$J,DFN,"PCTM",SDI)) Q:'$L(SDX)
.S SDY="" D S1("Primary Care Team",$P(SDX,U,2))
.S SDPH=$P($G(^SCTM(404.51,+SDX,0)),U,2) D:$L(SDPH) S2("Phone",SDPH)
.S:$P(SDX,U,3) SDPTA($P(SDX,U,3))=""
.D STL(SDY)
.Q
;
;PCP
S SDI=0 F S SDI=$O(^TMP("SDPLIST",$J,DFN,"PCPR",SDI)) Q:'SDI D
.S SDX=$G(^TMP("SDPLIST",$J,DFN,"PCPR",SDI)) Q:'$L(SDX)
.S SDY="" D S1("PC Provider",$P(SDX,U,2))
.D S2("Position",$P(SDX,U,4)),STL(SDY),PHONE($P(SDX,U,1))
.S SDY="" D S3("Pager",PAGER),S4("Phone",PHONE),STL(SDY)
.Q
;
;AP
S SDI=0 F S SDI=$O(^TMP("SDPLIST",$J,DFN,"PCAP",SDI)) Q:'SDI D
.S SDX=$G(^TMP("SDPLIST",$J,DFN,"PCAP",SDI)) Q:'$L(SDX)
.S SDY="" D S1("Associate Provider",$P(SDX,U,2)),S2("Position",$P(SDX,U,4)),STL(SDY),PHONE($P(SDX,U,1))
.S SDY="" D S3("Pager",PAGER),S4("Phone",PHONE),STL(SDY)
.Q
;
I $G(SDPRT)="P" D PRT G TDQ
S SDII=0 F S SDII=$O(^TMP("SDPLIST",$J,DFN,"NPCPOS",SDII)) Q:'SDII D
.S SDX=^TMP("SDPLIST",$J,DFN,"NPCPOS",SDII)
.Q:'$D(SDPTA(+$P(SDX,U,11)))
.S SDIII=0 F S SDIII=$O(^TMP("SDPLIST",$J,DFN,"NPCPR",SDIII)) Q:'SDIII D
..S SDZ=^TMP("SDPLIST",$J,DFN,"NPCPR",SDIII)
..Q:$P(SDZ,U,3)'=+SDX
..S SDY="" D S1("Non-PC Provider",$P(SDZ,U,2)),S2("Position",$P(SDZ,U,4)),STL(SDY)
;
S SDI=0 F S SDI=$O(^TMP("SDPLIST",$J,DFN,"NPCTM",SDI)) Q:'SDI D
.S SDX=^TMP("SDPLIST",$J,DFN,"NPCTM",SDI)
.S SDTEAM($P(SDX,U,2),+SDX)="",SDPTA=$P(SDX,U,3) Q:'SDPTA D
..S SDII=0 F S SDII=$O(^TMP("SDPLIST",$J,DFN,"NPCPOS",SDII)) Q:'SDII D
...S SDY=^TMP("SDPLIST",$J,DFN,"NPCPOS",SDII)
...Q:$P(SDY,U,11)'=SDPTA
...S SDTEAM($P(SDX,U,2),+SDX,$P(SDY,U,2),+SDY)="",SDIII=0
...F S SDIII=$O(^TMP("SDPLIST",$J,DFN,"NPCPR",SDIII)) Q:'SDIII D
....S SDZ=^TMP("SDPLIST",$J,DFN,"NPCPR",SDIII)
....Q:$P(SDZ,U,3)'=+SDY
....S SDTEAM($P(SDX,U,2),+SDX,$P(SDY,U,2),+SDY,$P(SDZ,U,2),+SDZ)=""
;
S SDTM="" F S SDTM=$O(SDTEAM(SDTM)) Q:SDTM="" D
.S SDTMN=0 F S SDTMN=$O(SDTEAM(SDTM,SDTMN)) Q:'SDTMN D
..I SDLN>0 D STL("")
..S SDY="" D S1("Non-PC Team",SDTM)
..S SDPH=$P($G(^SCTM(404.51,+SDTMN,0)),U,2) D:$L(SDPH) S2("Phone",SDPH),STL(SDY)
..S SDPO="" F S SDPO=$O(SDTEAM(SDTM,SDTMN,SDPO)) Q:SDPO="" S SDPON=0 D
...F S SDPON=$O(SDTEAM(SDTM,SDTMN,SDPO,SDPON)) Q:'SDPON D
....I $O(SDTEAM(SDTM,SDTMN,SDPO,SDPON,""))="" S SDY="" D S1("Non-PC Provider",""),S2("Position",SDPO),STL(SDY) Q
....S SDPR="" F S SDPR=$O(SDTEAM(SDTM,SDTMN,SDPO,SDPON,SDPR)) Q:SDPR="" D
.....S SDPRN=0 F S SDPRN=$O(SDTEAM(SDTM,SDTMN,SDPO,SDPON,SDPR,SDPRN)) Q:'SDPRN D
......S SDY="" D S1("Non-PC Provider",SDPR),S2("Position",SDPO),STL(SDY),PHONE(SDPRN)
......S SDY="" D S3("Pager",PAGER),S4("Phone",PHONE),STL(SDY)
;
I $G(SDPRT)="A" D PRT G TDQ
S SDY="",$E(SDY,29)="*** Team Information ***"
S ^TMP("SDTEMP",$J,1)=SDY,^TMP("SDTEMP",$J,2)=""
I SDLN=2 S SDY="",$E(SDY,20)="-- No team assignment information found --",^TMP("SDTEMP",$J,3)=SDY
S GBL=$G(GBL,"") I $L(GBL)<1 S GBL=$S('$D(VALMAR):"^TMP(""SDPP"",$J)",$L(VALMAR)>1:VALMAR,1:"^TMP(""SDPP"",$J)")
;add line at bottom of array for readability
S SDI=$O(^TMP("SDTEMP",$J,""),-1)+1,^TMP("SDTEMP",$J,SDI)=""
;respect the array count passed in to the function
S (SDII,VALMCNT)=$O(@GBL@(""),-1)+1
S SDI=0
F S SDI=$O(^TMP("SDTEMP",$J,SDI)) Q:'SDI D
.S SDX=^TMP("SDTEMP",$J,SDI),SDII=SDII+1
.S @GBL@(SDII,0)=SDX,VALMCNT=$G(VALMCNT)+1
.I SDLN<7,SDI>3 S SDII=SDII+1,@GBL@(SDII,0)="",VALMCNT=$G(VALMCNT)+1
.Q
TDQ F SDI="SDPLIST","SDTEMP" K ^TMP(SDI,$J,DFN)
Q
;
S1(SDT,SDX) ;Set first piece of string
; Input: SDT=subtitle, SDX=data value
S SDY=$J(SDT,18)_": "_$E(SDX,1,28) Q
;
S2(SDT,SDX) ;Set second piece of string
; Input: SDT=subtitle, SDX=data value
I $L($G(SDPRT)),SDCOL>0 Q
S $E(SDY,53)=$J(SDT,8)_": "_$E(SDX,1,18) Q
;
S3(SDT,SDX) ;Set first piece of string that displays phone numbers
; Input: SDT=subtitle, SDX=data value
S SDY=$J(SDT,30)_": "_$E(SDX,1,20) Q
;
S4(SDT,SDX) ;Set second piece of string that displays phone numbers
;Input: SDT=subtitle, SDX=data value
I $L($G(SDPRT)),SDCOL>0 Q
S $E(SDY,56)=$J(SDT,4)_": "_$E(SDX,1,20) Q
;
PHONE(IEN) ;Get provider's pager and phone numbers.
;Return: PAGER = Pager number
; PHONE = Phone number
NEW LIST
S (PAGER,PHONE)=""
Q:'$G(IEN)
Q:'$$NEWPERSN^SCMCGU(IEN,"LIST")
S PAGER=$P(LIST(IEN),U,5),PHONE=$P(LIST(IEN),U,2) Q
;
STL(SDY) ; Set text line
; Input: SDY=string
S SDLN=SDLN+1,^TMP("SDTEMP",$J,SDLN)=SDY Q
;
PRT ; Write assignment information
N SDI S SDI=0
F S SDI=$O(^TMP("SDTEMP",$J,SDI)) Q:'SDI D
.W !?(SDCOL),^TMP("SDTEMP",$J,SDI) Q
Q
;
PCLINE(DFN,SDATE) ;PC provider, associate and team in a single line
; Input: DFN=patient ifn
; SDATE=effective date (optional)
; Output: PC provider, associate and team formatted as 80 character
; line, or "" if none
;
N SDLIST,SDI,SDX,SDY,SDZ,SDL,SDC,SDTL
Q:'DFN "" S:$G(SDATE)<1 SDATE=DT S SDLIST="^TMP(""SDPLIST"",$J)"
F SDI="BEGIN","END" S SDATE(SDI)=SDATE
S SDATE="SDATE",SDI=$$GETALL^SCAPMCA(DFN,.SDATE,SDLIST)
S SDY="PC Prov: ^Assoc. Prov: ^Team: ",SDL=48,SDC=3,SDTL=0
S SDX(1)=$$PCL("PCPR"),SDX(2)=$$PCL("PCAP"),SDX(3)=$$PCL("PCTM")
K ^TMP("SDPLIST",$J,DFN)
F SDI=1,2,3 S SDZ($L(SDX(SDI)),SDI)=""
S SDI="" F S SDI=$O(SDZ(SDI)) Q:SDI="" D
.S SDII=0 F S SDII=$O(SDZ(SDI,SDII)) Q:'SDII D
..I 'SDI S SDC=SDC-1 Q
..I SDI<(SDL\SDC) S SDX(SDII)=$P(SDY,U,SDII)_SDX(SDII),SDL=SDL-SDI,SDC=SDC-1 Q
..S SDX(SDII)=$P(SDY,U,SDII)_$E(SDX(SDII),1,(SDL\SDC))
;
F SDI=1,2,3 S SDTL=SDTL+$L(SDX(SDI))
Q:SDTL=0 ""
S SDX=SDX(1),$E(SDX,($L(SDX)+1+(80-SDTL\2)))=SDX(2),$E(SDX,81-$L(SDX(3)))=SDX(3)
Q SDX
;
PCL(SDSUB) ; Get name value
; Input: SDSUB=node from GETALL^SCAPMCA
N SDN S SDN=+$G(^TMP("SDPLIST",$J,DFN,"PCPOS",0))
Q:SDN=0 ""
Q:SDN>1 "[ambiguous data]"
S SDN=+$G(^TMP("SDPLIST",$J,DFN,SDSUB,0))
Q:SDN=0 ""
Q:SDN>1 "[ambiguous data]"
Q $P($G(^TMP("SDPLIST",$J,DFN,SDSUB,1)),U,2)
;
LAST() ; Output - the latest date, beginning day or -100 days
; the APPOINTMENT STATUS UPDATE LOG was updated
N SDI,LAST
F SDI=0:1:100 S X1=DT,X2=-SDI D C^%DTC S LAST=$O(^SDD(409.65,"B",X,0)) S LAST1=$P($G(^SDD(409.65,+LAST,0)),U,5) Q:LAST1
Q LAST
;
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGSDUTL 9891 printed Apr 09, 2024@21:39:27 Page 2
DGSDUTL ;ALB/PHH,RMM - DG/SD API UTILITIES ;3/4/2004 10:03
+1 ;;5.3;Registration;**568**;AUG 13, 1993
+2 ;
+3 QUIT
PCTEAM(DFN,DATE,ASSTYPE) ; Get Primary Care Team
+1 ; DFN - IEN of patient file (#2)
+2 ; DATE - Date of interest (Default=DT)
+3 ; ASSTYPE - Assignment Type (Default=1 for PC Team)
+4 ;
+5 NEW RETVAL,ACTDT,SCTM,SCPTTMA,INACTDT
+6 SET RETVAL=0
+7 if '$GET(DFN)
QUIT RETVAL
+8 SET DATE=$GET(DATE,DT)
SET ASSTYPE=$GET(ASSTYPE,1)
+9 ;
+10 ; Returns pointer to file #404.51 if it exists, 0 if not
+11 SET ACTDT=+$ORDER(^SCPT(404.42,"APCTM",+DFN,+ASSTYPE,(DATE+.000001)),-1)
+12 SET SCTM=$ORDER(^SCPT(404.42,"APCTM",+DFN,+ASSTYPE,+ACTDT,0))
+13 SET SCPTTMA=$ORDER(^SCPT(404.42,"APCTM",+DFN,+ASSTYPE,+ACTDT,+SCTM,0))
+14 SET INACTDT=$PIECE($GET(^SCPT(404.42,+SCPTTMA,0)),U,9)
+15 SET RETVAL=$SELECT('INACTDT:+SCTM,(INACTDT'<DATE):+SCTM,1:0)
+16 SET RETVAL=$SELECT('$GET(RETVAL):"",1:RETVAL_U_$PIECE($GET(^SCTM(404.51,+RETVAL,0)),U,1))
+17 QUIT RETVAL
+18 ;
PCPRACT(DFN,DATE,PCROLE) ; Get PC Practitioner
+1 ; DFN - Pointer to Patient file
+2 ; DATE - Date of interest
+3 ; PCROLE - Practitioner Position where '1' = PC provider
+4 ; '2' = PC attending
+5 ; '3' = PC associate provider
+6 ; Returned: Pointer to file #200 ^ External value of name
+7 ; or, if error or none defined, returns a 0 or null
+8 ;
+9 NEW RETVAL,SCOK,SCTP,ACTDT,TPLP,TPDALP,INACTDT,PCAP
+10 SET RETVAL=0
+11 if '$GET(DFN)
QUIT RETVAL
+12 SET DATE=$GET(DATE,DT)
SET PCROLE=$GET(PCROLE,1)
+13 ;
+14 ; Returns pointer to file #404.57 if it exists, 0 if not
+15 SET SCOK=1
SET SCTP=0
+16 SET ACTDT=+$ORDER(^SCPT(404.43,"APCPOS",+DFN,+PCROLE,(DATE+.000001)),-1)
+17 FOR TPLP=0:0
SET TPLP=$ORDER(^SCPT(404.43,"APCPOS",+DFN,+PCROLE,+ACTDT,TPLP))
if TPLP=""!(SCTP=-1)
QUIT
Begin DoDot:1
+18 FOR TPDALP=0:0
SET TPDALP=$ORDER(^SCPT(404.43,"APCPOS",+DFN,+PCROLE,+ACTDT,TPLP,TPDALP))
if TPDALP=""
QUIT
Begin DoDot:2
+19 SET INACTDT=$PIECE($GET(^SCPT(404.43,+TPDALP,0)),U,4)
+20 ;
+21 ; Error if it's already an active date
+22 IF 'INACTDT
SET SCTP=$SELECT(SCTP>0:-1,1:TPLP)
QUIT
+23 IF INACTDT'<DATE
SET SCTP=$SELECT(SCTP>0:-1,1:TPLP)
End DoDot:2
if SCTP=-1
QUIT
End DoDot:1
+24 SET RETVAL=+SCTP
+25 SET RETVAL=$SELECT('$GET(RETVAL):"",RETVAL=-1:"",1:RETVAL_U_$PIECE($GET(^SCTM(404.57,+RETVAL,0)),U,1))
+26 ;
+27 SET SCTP=+RETVAL
SET PCAP=+$GET(PCROLE,1)
SET PCAP=$SELECT(PCAP=0:1,PCAP>3:1,1:PCAP)
+28 SET PCROLE=$SELECT(PCROLE=0:1,PCROLE>2:1,1:PCROLE)
+29 SET RETVAL=$SELECT('SCTP:"",1:$$PCPROV^SCAPMCU3(SCTP,.DATE,PCAP))
+30 QUIT RETVAL
+31 ;
DATE ; Get Begin Date and End Date
+1 if $DATA(%DT(0))
SET SDT0=%DT(0)
if $DATA(SDT00)
SET %DT=SDT00
SET POP=0
KILL BEGDATE,ENDDATE
WRITE !!,"**** Date Range Selection ****"
+2 WRITE !
SET %DT=$SELECT($DATA(SDT00):SDT00,1:"AE")
SET %DT("A")=" Beginning DATE : "
DO ^%DT
if Y<0
SET POP=1
if Y<0
GOTO EX
SET (BEGDATE,SDBD)=Y
+3 WRITE !
SET %DT="AE"
SET %DT("A")=" Ending DATE : "
DO ^%DT
KILL %DT
if Y<0
SET POP=1
if Y<0
GOTO EX
if Y<SDBD
GOTO HELP
WRITE !
SET (ENDDATE,SDED)=Y
EX KILL SDT0,SDT00
QUIT
HELP WRITE "??",!?5,"Ending date must not be before beginning date"
if $DATA(SDT0)
SET %DT(0)=SDT0
GOTO DATE
+1 ;
TDATA(DFN,VALMCNT,SDATE,SDPRT,SDCOL) ;
+1 ;Team information - gather, format and optionally print.
+2 ;
+3 ; Input: DFN=patient ifn
+4 ; VALMCNT=variable to return number of lines (pass by reference)
+5 ; SDATE=effective date (optional)
+6 ; SDPRT=print flag, 'P' for PC info only, 'A' for all (optional)
+7 ; SDCOL=column to print in conjunction with SDPRT flag (optional)
+8 ;
+9 if DFN'>0
QUIT
+10 NEW SDI,SDATE,SDLIST,SDX,SDLN,SDY,SDPH,SDTEAM,SDPTA,SDII,SDIII,SDZ
+11 NEW SDTM,SDTMN,SDPO,SDPON,SDPR,SDPRN,PAGER,PHONE
+12 ;
+13 FOR SDI="SDPLIST","SDTEMP"
KILL ^TMP(SDI,$JOB)
+14 SET SDCOL=+$GET(SDCOL)
SET SDATE=$GET(SDATE)
if SDATE<1
SET SDATE=DT
+15 FOR SDI="BEGIN","END"
SET SDATE(SDI)=SDATE
+16 SET SDATE="SDATE"
SET SDLIST="^TMP(""SDPLIST"",$J)"
SET SDLN=2
+17 SET SDI=$$GETALL^SCAPMCA(DFN,.SDATE,SDLIST)
+18 ;
+19 ;PC Team
+20 SET SDI=0
FOR
SET SDI=$ORDER(^TMP("SDPLIST",$JOB,DFN,"PCTM",SDI))
if 'SDI
QUIT
Begin DoDot:1
+21 SET SDX=$GET(^TMP("SDPLIST",$JOB,DFN,"PCTM",SDI))
if '$LENGTH(SDX)
QUIT
+22 SET SDY=""
DO S1("Primary Care Team",$PIECE(SDX,U,2))
+23 SET SDPH=$PIECE($GET(^SCTM(404.51,+SDX,0)),U,2)
if $LENGTH(SDPH)
DO S2("Phone",SDPH)
+24 if $PIECE(SDX,U,3)
SET SDPTA($PIECE(SDX,U,3))=""
+25 DO STL(SDY)
+26 QUIT
End DoDot:1
+27 ;
+28 ;PCP
+29 SET SDI=0
FOR
SET SDI=$ORDER(^TMP("SDPLIST",$JOB,DFN,"PCPR",SDI))
if 'SDI
QUIT
Begin DoDot:1
+30 SET SDX=$GET(^TMP("SDPLIST",$JOB,DFN,"PCPR",SDI))
if '$LENGTH(SDX)
QUIT
+31 SET SDY=""
DO S1("PC Provider",$PIECE(SDX,U,2))
+32 DO S2("Position",$PIECE(SDX,U,4))
DO STL(SDY)
DO PHONE($PIECE(SDX,U,1))
+33 SET SDY=""
DO S3("Pager",PAGER)
DO S4("Phone",PHONE)
DO STL(SDY)
+34 QUIT
End DoDot:1
+35 ;
+36 ;AP
+37 SET SDI=0
FOR
SET SDI=$ORDER(^TMP("SDPLIST",$JOB,DFN,"PCAP",SDI))
if 'SDI
QUIT
Begin DoDot:1
+38 SET SDX=$GET(^TMP("SDPLIST",$JOB,DFN,"PCAP",SDI))
if '$LENGTH(SDX)
QUIT
+39 SET SDY=""
DO S1("Associate Provider",$PIECE(SDX,U,2))
DO S2("Position",$PIECE(SDX,U,4))
DO STL(SDY)
DO PHONE($PIECE(SDX,U,1))
+40 SET SDY=""
DO S3("Pager",PAGER)
DO S4("Phone",PHONE)
DO STL(SDY)
+41 QUIT
End DoDot:1
+42 ;
+43 IF $GET(SDPRT)="P"
DO PRT
GOTO TDQ
+44 SET SDII=0
FOR
SET SDII=$ORDER(^TMP("SDPLIST",$JOB,DFN,"NPCPOS",SDII))
if 'SDII
QUIT
Begin DoDot:1
+45 SET SDX=^TMP("SDPLIST",$JOB,DFN,"NPCPOS",SDII)
+46 if '$DATA(SDPTA(+$PIECE(SDX,U,11)))
QUIT
+47 SET SDIII=0
FOR
SET SDIII=$ORDER(^TMP("SDPLIST",$JOB,DFN,"NPCPR",SDIII))
if 'SDIII
QUIT
Begin DoDot:2
+48 SET SDZ=^TMP("SDPLIST",$JOB,DFN,"NPCPR",SDIII)
+49 if $PIECE(SDZ,U,3)'=+SDX
QUIT
+50 SET SDY=""
DO S1("Non-PC Provider",$PIECE(SDZ,U,2))
DO S2("Position",$PIECE(SDZ,U,4))
DO STL(SDY)
End DoDot:2
End DoDot:1
+51 ;
+52 SET SDI=0
FOR
SET SDI=$ORDER(^TMP("SDPLIST",$JOB,DFN,"NPCTM",SDI))
if 'SDI
QUIT
Begin DoDot:1
+53 SET SDX=^TMP("SDPLIST",$JOB,DFN,"NPCTM",SDI)
+54 SET SDTEAM($PIECE(SDX,U,2),+SDX)=""
SET SDPTA=$PIECE(SDX,U,3)
if 'SDPTA
QUIT
Begin DoDot:2
+55 SET SDII=0
FOR
SET SDII=$ORDER(^TMP("SDPLIST",$JOB,DFN,"NPCPOS",SDII))
if 'SDII
QUIT
Begin DoDot:3
+56 SET SDY=^TMP("SDPLIST",$JOB,DFN,"NPCPOS",SDII)
+57 if $PIECE(SDY,U,11)'=SDPTA
QUIT
+58 SET SDTEAM($PIECE(SDX,U,2),+SDX,$PIECE(SDY,U,2),+SDY)=""
SET SDIII=0
+59 FOR
SET SDIII=$ORDER(^TMP("SDPLIST",$JOB,DFN,"NPCPR",SDIII))
if 'SDIII
QUIT
Begin DoDot:4
+60 SET SDZ=^TMP("SDPLIST",$JOB,DFN,"NPCPR",SDIII)
+61 if $PIECE(SDZ,U,3)'=+SDY
QUIT
+62 SET SDTEAM($PIECE(SDX,U,2),+SDX,$PIECE(SDY,U,2),+SDY,$PIECE(SDZ,U,2),+SDZ)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+63 ;
+64 SET SDTM=""
FOR
SET SDTM=$ORDER(SDTEAM(SDTM))
if SDTM=""
QUIT
Begin DoDot:1
+65 SET SDTMN=0
FOR
SET SDTMN=$ORDER(SDTEAM(SDTM,SDTMN))
if 'SDTMN
QUIT
Begin DoDot:2
+66 IF SDLN>0
DO STL("")
+67 SET SDY=""
DO S1("Non-PC Team",SDTM)
+68 SET SDPH=$PIECE($GET(^SCTM(404.51,+SDTMN,0)),U,2)
if $LENGTH(SDPH)
DO S2("Phone",SDPH)
DO STL(SDY)
+69 SET SDPO=""
FOR
SET SDPO=$ORDER(SDTEAM(SDTM,SDTMN,SDPO))
if SDPO=""
QUIT
SET SDPON=0
Begin DoDot:3
+70 FOR
SET SDPON=$ORDER(SDTEAM(SDTM,SDTMN,SDPO,SDPON))
if 'SDPON
QUIT
Begin DoDot:4
+71 IF $ORDER(SDTEAM(SDTM,SDTMN,SDPO,SDPON,""))=""
SET SDY=""
DO S1("Non-PC Provider","")
DO S2("Position",SDPO)
DO STL(SDY)
QUIT
+72 SET SDPR=""
FOR
SET SDPR=$ORDER(SDTEAM(SDTM,SDTMN,SDPO,SDPON,SDPR))
if SDPR=""
QUIT
Begin DoDot:5
+73 SET SDPRN=0
FOR
SET SDPRN=$ORDER(SDTEAM(SDTM,SDTMN,SDPO,SDPON,SDPR,SDPRN))
if 'SDPRN
QUIT
Begin DoDot:6
+74 SET SDY=""
DO S1("Non-PC Provider",SDPR)
DO S2("Position",SDPO)
DO STL(SDY)
DO PHONE(SDPRN)
+75 SET SDY=""
DO S3("Pager",PAGER)
DO S4("Phone",PHONE)
DO STL(SDY)
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+76 ;
+77 IF $GET(SDPRT)="A"
DO PRT
GOTO TDQ
+78 SET SDY=""
SET $EXTRACT(SDY,29)="*** Team Information ***"
+79 SET ^TMP("SDTEMP",$JOB,1)=SDY
SET ^TMP("SDTEMP",$JOB,2)=""
+80 IF SDLN=2
SET SDY=""
SET $EXTRACT(SDY,20)="-- No team assignment information found --"
SET ^TMP("SDTEMP",$JOB,3)=SDY
+81 SET GBL=$GET(GBL,"")
IF $LENGTH(GBL)<1
SET GBL=$SELECT('$DATA(VALMAR):"^TMP(""SDPP"",$J)",$LENGTH(VALMAR)>1:VALMAR,1:"^TMP(""SDPP"",$J)")
+82 ;add line at bottom of array for readability
+83 SET SDI=$ORDER(^TMP("SDTEMP",$JOB,""),-1)+1
SET ^TMP("SDTEMP",$JOB,SDI)=""
+84 ;respect the array count passed in to the function
+85 SET (SDII,VALMCNT)=$ORDER(@GBL@(""),-1)+1
+86 SET SDI=0
+87 FOR
SET SDI=$ORDER(^TMP("SDTEMP",$JOB,SDI))
if 'SDI
QUIT
Begin DoDot:1
+88 SET SDX=^TMP("SDTEMP",$JOB,SDI)
SET SDII=SDII+1
+89 SET @GBL@(SDII,0)=SDX
SET VALMCNT=$GET(VALMCNT)+1
+90 IF SDLN<7
IF SDI>3
SET SDII=SDII+1
SET @GBL@(SDII,0)=""
SET VALMCNT=$GET(VALMCNT)+1
+91 QUIT
End DoDot:1
TDQ FOR SDI="SDPLIST","SDTEMP"
KILL ^TMP(SDI,$JOB,DFN)
+1 QUIT
+2 ;
S1(SDT,SDX) ;Set first piece of string
+1 ; Input: SDT=subtitle, SDX=data value
+2 SET SDY=$JUSTIFY(SDT,18)_": "_$EXTRACT(SDX,1,28)
QUIT
+3 ;
S2(SDT,SDX) ;Set second piece of string
+1 ; Input: SDT=subtitle, SDX=data value
+2 IF $LENGTH($GET(SDPRT))
IF SDCOL>0
QUIT
+3 SET $EXTRACT(SDY,53)=$JUSTIFY(SDT,8)_": "_$EXTRACT(SDX,1,18)
QUIT
+4 ;
S3(SDT,SDX) ;Set first piece of string that displays phone numbers
+1 ; Input: SDT=subtitle, SDX=data value
+2 SET SDY=$JUSTIFY(SDT,30)_": "_$EXTRACT(SDX,1,20)
QUIT
+3 ;
S4(SDT,SDX) ;Set second piece of string that displays phone numbers
+1 ;Input: SDT=subtitle, SDX=data value
+2 IF $LENGTH($GET(SDPRT))
IF SDCOL>0
QUIT
+3 SET $EXTRACT(SDY,56)=$JUSTIFY(SDT,4)_": "_$EXTRACT(SDX,1,20)
QUIT
+4 ;
PHONE(IEN) ;Get provider's pager and phone numbers.
+1 ;Return: PAGER = Pager number
+2 ; PHONE = Phone number
+3 NEW LIST
+4 SET (PAGER,PHONE)=""
+5 if '$GET(IEN)
QUIT
+6 if '$$NEWPERSN^SCMCGU(IEN,"LIST")
QUIT
+7 SET PAGER=$PIECE(LIST(IEN),U,5)
SET PHONE=$PIECE(LIST(IEN),U,2)
QUIT
+8 ;
STL(SDY) ; Set text line
+1 ; Input: SDY=string
+2 SET SDLN=SDLN+1
SET ^TMP("SDTEMP",$JOB,SDLN)=SDY
QUIT
+3 ;
PRT ; Write assignment information
+1 NEW SDI
SET SDI=0
+2 FOR
SET SDI=$ORDER(^TMP("SDTEMP",$JOB,SDI))
if 'SDI
QUIT
Begin DoDot:1
+3 WRITE !?(SDCOL),^TMP("SDTEMP",$JOB,SDI)
QUIT
End DoDot:1
+4 QUIT
+5 ;
PCLINE(DFN,SDATE) ;PC provider, associate and team in a single line
+1 ; Input: DFN=patient ifn
+2 ; SDATE=effective date (optional)
+3 ; Output: PC provider, associate and team formatted as 80 character
+4 ; line, or "" if none
+5 ;
+6 NEW SDLIST,SDI,SDX,SDY,SDZ,SDL,SDC,SDTL
+7 if 'DFN
QUIT ""
if $GET(SDATE)<1
SET SDATE=DT
SET SDLIST="^TMP(""SDPLIST"",$J)"
+8 FOR SDI="BEGIN","END"
SET SDATE(SDI)=SDATE
+9 SET SDATE="SDATE"
SET SDI=$$GETALL^SCAPMCA(DFN,.SDATE,SDLIST)
+10 SET SDY="PC Prov: ^Assoc. Prov: ^Team: "
SET SDL=48
SET SDC=3
SET SDTL=0
+11 SET SDX(1)=$$PCL("PCPR")
SET SDX(2)=$$PCL("PCAP")
SET SDX(3)=$$PCL("PCTM")
+12 KILL ^TMP("SDPLIST",$JOB,DFN)
+13 FOR SDI=1,2,3
SET SDZ($LENGTH(SDX(SDI)),SDI)=""
+14 SET SDI=""
FOR
SET SDI=$ORDER(SDZ(SDI))
if SDI=""
QUIT
Begin DoDot:1
+15 SET SDII=0
FOR
SET SDII=$ORDER(SDZ(SDI,SDII))
if 'SDII
QUIT
Begin DoDot:2
+16 IF 'SDI
SET SDC=SDC-1
QUIT
+17 IF SDI<(SDL\SDC)
SET SDX(SDII)=$PIECE(SDY,U,SDII)_SDX(SDII)
SET SDL=SDL-SDI
SET SDC=SDC-1
QUIT
+18 SET SDX(SDII)=$PIECE(SDY,U,SDII)_$EXTRACT(SDX(SDII),1,(SDL\SDC))
End DoDot:2
End DoDot:1
+19 ;
+20 FOR SDI=1,2,3
SET SDTL=SDTL+$LENGTH(SDX(SDI))
+21 if SDTL=0
QUIT ""
+22 SET SDX=SDX(1)
SET $EXTRACT(SDX,($LENGTH(SDX)+1+(80-SDTL\2)))=SDX(2)
SET $EXTRACT(SDX,81-$LENGTH(SDX(3)))=SDX(3)
+23 QUIT SDX
+24 ;
PCL(SDSUB) ; Get name value
+1 ; Input: SDSUB=node from GETALL^SCAPMCA
+2 NEW SDN
SET SDN=+$GET(^TMP("SDPLIST",$JOB,DFN,"PCPOS",0))
+3 if SDN=0
QUIT ""
+4 if SDN>1
QUIT "[ambiguous data]"
+5 SET SDN=+$GET(^TMP("SDPLIST",$JOB,DFN,SDSUB,0))
+6 if SDN=0
QUIT ""
+7 if SDN>1
QUIT "[ambiguous data]"
+8 QUIT $PIECE($GET(^TMP("SDPLIST",$JOB,DFN,SDSUB,1)),U,2)
+9 ;
LAST() ; Output - the latest date, beginning day or -100 days
+1 ; the APPOINTMENT STATUS UPDATE LOG was updated
+2 NEW SDI,LAST
+3 FOR SDI=0:1:100
SET X1=DT
SET X2=-SDI
DO C^%DTC
SET LAST=$ORDER(^SDD(409.65,"B",X,0))
SET LAST1=$PIECE($GET(^SDD(409.65,+LAST,0)),U,5)
if LAST1
QUIT
+4 QUIT LAST
+5 ;
+6 ;
+7 QUIT
