PSODEMSB ;EPIP/RTW - PSODEM subroutines ; 7/29/17 3:24pm
;;7.0;OUTPATIENT PHARMACY;**452,564,570,607,664**;Dec 1997;Build 6
;------------------------------------------------------------------
; External reference to $$OUTPTTM^SDUTL3 supported by ICR 1252
; External reference to ^DIE supported by ICR 2022
; External references to $$GET1^DIQ supported by ICR 2056
; External reference to ^PS(55 supported by ICR 2228
; External reference to $$GETALL^SCAPMCA supported by ICR 2848
; External reference to VST^ORWCV supported by ICR 4211
; External reference to $$SDAPI^SDMACA301 supported by ICR 4433
; External reference to ^DD("DILOCKTM" supported by ICR 4909
; External reference to ^DIC supported by ICR 10006
; External reference to ^DIR supported by ICR 10026
; External reference to ^DPT( supported by ICR 10035
; External reference to ^VA(200 supported by ICR 10060
; External reference to LOCK^DILF($NA( supported by ICR 2054
;------------------------------------------------------------------
DEMOG(PSODFN) ;
; Extend patient demographics with PC Team, Current Facility
; Remarks, and Clinical Alerts, pause the screen until <Enter>
; Input:
; DFN ; Required ; IEN of Patient file (#2) entry
;
Q:$D(XQORNOD(0))
N PSOTEAM,PSOCLINA,DIR,DIRUT,PG,X,Y
I $G(XQY0)["PSO P",(IO=IO(0)),$E(IOST)="C" D ; PSO*7*607
. W !
. S DIR("T")=DTIME,DIR(0)="EA",DIR("A")="Press <Enter> to continue: " D ^DIR
;
S PG=0
D PCTEAM(PSODFN)
I 'PSOTEAM W !! D HDR("Extended Patient Demographics:")
D REMARKS(PSODFN)
W !?1,"Assigned/Recent Facility: ",$$CURRFAC(PSODFN)
D CA(PSODFN)
Q:$D(DIRUT)
I $G(XQY0)'["OR CPRS GUI CHART",(IO=IO(0)),$E(IOST)="C" D ;
. W !
. S DIR("T")=DTIME,DIR(0)="EA",DIR("A")="Press <Enter> to continue: " D ^DIR
Q
;------------------------------------------------------------------
CA(PSODFN) ; Print PHARMACY PATIENT CLINICAL ALERTS multiple field (#2)
; Input:
; DFN ; Required ; IEN of Patient file (#2) entry
;
N PSOFLAG1,PSODATER
;
Q:'$G(PSODFN) ; Quit, if no Patient IEN
Q:'$P($G(^PS(55,PSODFN,2,0)),U,4) ; No CLINICAL ALERTS
;
S PSOFLAG1=1,PSOCLINA=0 ; First time flag to display field header
;
; PSODATER format DINUMed: 9999999.999999-CLINICAL ALERT DATE/TIME
S PSODATER=0
F S PSODATER=$O(^PS(55,PSODFN,2,PSODATER)) Q:'PSODATER D Q:$D(DIRUT) ;
. I PSOFLAG1=1 W !!,"Clinical Alerts:" S PSOFLAG1=0
. ; Display CLINICAL ALERT DATE/TIME (#.01) & CLINICAL ALERT (#1)
. W !!,?2,$$GET1^DIQ(55.0109,PSODATER_","_PSODFN,.01)
. W " ",$$GET1^DIQ(55.0109,PSODATER_","_PSODFN,1)
. I '$G(PAGE)!($Y+7>IOSL),$O(^PS(55,PSODFN,2,PSODATER)) D HDR("Clinical Alerts:")
Q
;------------------------------------------------------------------
HDR(HDR) ;
N DIR
I '$D(OPT) S OPT=$G(XQY0) ;p664 OPT=Option
W !
;PSO*7*607
I PG,IO=IO(0),$E(IOST)="C" S DIR("T")=DTIME,DIR(0)="EA",DIR("A")="Type <Enter> to continue or '^' to exit Clinical Alerts:" D ^DIR I $D(DIRUT) Q
I $G(XQY0)["PSO LMOE FINISH"!($G(XQY0)["PSO VIEW") D ;P664
. I $G(OPT)'=$G(XQY0) S PAGE=0 S OPT=$G(XQY0)
I HDR]"" W @IOF S PAGE=$G(PAGE)+1 W HDR,?70,"Page: ",PAGE,! S $Y=1
Q
CURRFAC(PSODFN) ; Return: The Assigned/Recent Facility INSTITUTION for the Patient's DFN
; Input:
; DFN ; Required ; IEN of Patient file (#2) entry
;
N DATA,DTBEG,DTEND,FLAGQ,IEN4,ORVISIT,PCTEAM,PREVSCDT,RETURN,SUB
;
S RETURN="" ; Default return value is null
;
I $$GET1^DIQ(2,PSODFN,.351,"I") Q RETURN ; .351 Patient DATE OF DEATH
;
; The first choice for returning the INSTITUTION would be the
; INSTITUTION field (#.07) of the TEAM file (#404.51)
;
S PCTEAM=$$OUTPTTM^SDUTL3(PSODFN,DT,1) ; IEN^NAME of file (#404.51) ; ICR #1252
; *** End patch #1 change #1 by R2/Confer on 08/07/2015
I +PCTEAM>0 D Q RETURN
. S RETURN=$$GET1^DIQ(404.51,+PCTEAM,.07) ; INSTITUTION [R*P4']
;
; Return future appointments and past visits for a patient
;
S DTBEG=DT-20000 ; Begin with TODAY - 2 years
S DTEND=DT+20000 ; End with TODAY + 2 years
D VST^ORWCV(.ORVISIT,PSODFN,DTBEG,DTEND) ; ICR #4211
;
; Process ORVISIT array in reverse chronological order. Quantify
; visits & appointments based upon the INSTITUTION pointer field (#3)
; of the HOSPITAL LOCATION file (#44). Once the count reaches
; 3 for a given INSTITUTION, that INSTITUION is returned.
;
S FLAGQ=0 ; Quit flag, set to 1 once the Institution is determined
S PREVSCDT="" ; Previous appt/visit date
S SUB=":" ;.... Sequential number of ORVISIT array subscript
F S SUB=$O(ORVISIT(SUB),-1) Q:'SUB!FLAGQ D ;
. N DATA,SC,SCDT
. S DATA=ORVISIT(SUB)
. S SC=$P($P(DATA,U),";",3) Q:'SC ; HOSPITAL LOCATION file (#44) IEN
. S IEN4=+$$GET1^DIQ(44,SC,3,"I") ; INSTITUTION file (#4) IEN
. S SCDT=$P($P(DATA,U),";",2) Q:'SCDT ; Appt/visit date (fm format)
. S SCDT=$P(SCDT,".") ; Strip the time
. Q:SCDT=PREVSCDT ; Appt/visit must be a N day
. I '$D(IEN4(IEN4)) S IEN4(IEN4)=0 ; Initialize INSTITUTION counter
. S IEN4(IEN4)=IEN4(IEN4)+1 ; Quantify by INSTITUTION ien
. I IEN4(IEN4)=3 D Q ; When count reaches 3, INSTITUTION found
. . S RETURN=$$GET1^DIQ(4,IEN4,.01) ; INSTITUTION NAME (#.01)
. . S FLAGQ=1
. ;
. S PREVSCDT=SCDT ; Save as previous appt/visit date
;
; IF no PCTEAM INSTITUTION
; AND three appt/visits were not found for an INSTITUTION ien
; AND at least one appt/visit was found
; THEN
; return the most recent appt/visit INSTITUTION
;
I RETURN="" D ;
. N DATA,IEN4,SC,SUB
. S SUB=$O(ORVISIT(":"),-1) Q:'SUB
. S DATA=ORVISIT(SUB)
. S SC=$P($P(DATA,U),";",3) Q:'SC ; HOSPITAL LOCATION file (#44) IEN
. S IEN4=$$GET1^DIQ(44,SC,3,"I") ; INSTITUTION file (#4) IEN
. S RETURN=$$GET1^DIQ(4,IEN4,.01) ; INSTITUTION file (#4) NAME (#.01)
;
Q RETURN
;------------------------------------------------------------------
PCTEAM(PSODFN) ; Display current PC TEAM, PC Provider, and phone.
; Input:
; DFN ; Required ; IEN of Patient file (#2) entry
;
S PSOTEAM=0
N DATA,PAGER,PCPOS,PCPROV,PCPROVI,PHONE,PCTM
N SCDT2,SCP,SDI,TEAM,TEAMI
;
S PCTM="^TMP(""SDPLIST"",$J)"
K @PCTM
S SDI=$$GETALL^SCAPMCA(PSODFN,DT,PCTM) Q:'SDI ; ICR #2848
S SDI=0
F S SDI=$O(^TMP("SDPLIST",$J,PSODFN,"PCTM",SDI)) Q:'SDI D ;
. ;
. ; "PCTM" node (PC Team)
. S PSOTEAM=1
. S DATA=$G(^TMP("SDPLIST",$J,PSODFN,"PCTM",SDI)) Q:DATA=""
. S TEAMI=$P(DATA,U,1) ; IEN of TEAM file (#404.51)
. S TEAM=$P(DATA,U,2) ;. NAME of TEAM file entry
. ;
. ; "PCPR" node (PC Provider)
. S DATA=$G(^TMP("SDPLIST",$J,PSODFN,"PCPR",SDI))
. S PCPROVI=+$P(DATA,U,1) ; IEN of PC Provider
. S PCPROV=$P(DATA,U,2) ;. PC Provider
. S PCPOS=$P(DATA,U,4) ;.. PC Provider Position
. S PAGER=$$GET1^DIQ(200,PCPROVI,.138) ; DIGITAL PAGER
. S:PAGER="" PAGER=$$GET1^DIQ(200,PCPROVI,.137) ; VOICE PAGER
. S PHONE=$$GET1^DIQ(200,PCPROVI,.132) ; OFFICE PHONE
. ;
. I PSOTEAM W !! D HDR("Extended Patient Demographics:")
. ;
. W !," Primary Care Team: ",TEAM
. W ?52," Phone: ",$$GET1^DIQ(404.51,TEAMI,.02) ; TEAM PHONE NUMBER
. ;
. W !," PC Provider: ",PCPROV
. W ?52,"Position: ",$E(PCPOS,1,18)
. ;
. W !?13,"Pager: ",PAGER
. W ?52," Phone: ",PHONE
;
K @PCTM
Q
;------------------------------------------------------------------
; Input:
; DFN ; Required ; IEN of Patient file (#2) entry
;
W !?11,"Remarks: ",$$GET1^DIQ(2,PSODFN_",",.091)
;
Q
;------------------------------------------------------------------
ENTER ; PSO CLINICAL ENTER/EDIT OPTION ENTRY POINT.
N PSODFN
PROMPT ;
W @IOF,!?1,"*** CLINICAL ALERT ENTER/EDIT ***"
START ;
W !
S PSODFN=+$$PATIENT G:'PSODFN EXIT W ! ; Prompt for Select PHARMACY PATIENT
D EDITCA(PSODFN) ; Edit CLINICAL ALERTS (multiple)
G START
;
EXIT ;
Q
;------------------------------------------------------------------
EDITCA(PSODFN) ; Edit the CLINICAL ALERTS multiple (#109) of file (#55)
; Input:
; DFN ; Patient file (#2) entry internal entry number
;
NEW %,%X,%Y,D,D0,D1,DA,DG,DI,DIC,DIDEL,DIE,DIERR,DIW,DQ,DR,DTOUT,X
;
S DA=PSODFN
S DIE="^PS(55,",DR="[PSO CLINICAL ALERT ENTER/EDIT]"
;
D LOCK^DILF($NA(^PS(55,DA))) E D Q
. W $C(7),!?4
. W "Patient ",$$GET1^DIQ(2,DA,.01)," is being edited by another user."
D ^DIE
LOCK -^PS(55,DA)
;
Q
;-----------------------------------------------------------------
PATIENT() ; Extrinsic, prompt for 'Select PHARMACY PATIENT: '
; Output:
; IEN^Name ; Of the selected Pharmacy Patient file #55 entry
; Return null if no patient selected
;
N %,%H,%I,%X,%Y,C,D,D0,DA,DDH,DG,DIC,DILN,DINUM,DIPGM,DIY
N DLAYGO,DTOUT,DUOUT,I,RETURN,X,Y
;
S RETURN=""
S DIC="^PS(55,"
S DIC(0)="AEMQZ"
D ^DIC I Y>0 S RETURN=+Y_"^"_Y(0,0)
;
Q RETURN
;
APPT() ; get appointments up to +/-2 yrs from now
; return null or name of institution
; ICR# 10061 - VADPT supported
; ICR# 10040 - FM read of file 44, field 3 supported
; ICR# 2171 - $$NS^XUAF4
N I,X,Y,DIV,F4,GL,NOW,VAERR,VAST,XI,XE
S GL=$NA(^UTILITY("VASD",$J)) K @GL
S NOW=$$NOW^XLFDT
S VASD("F")=DT-20000
S VASD("T")=DT+20000
D SDA^VADPT
; div("F",inst)=total count of visits
; div("F",0) = appt_dt ^ inst_ptr
; div("P") set up similarly for past kept appointments
; ^utility("VASD",$j,inc,"I"/"E")=appt_dt^clinic^status^appt_type
; only use one visit per day for division count
; if institution has more than 2 future appts, use that
; if institution has more than 2 past appts, use that
; if future appts, use institution of next appt
; if past appts, use institution of last appt
; use ^UTILITY("VASD",$J,"D",DATE)="" to track visit days
S F4="",I=0 F S I=$O(@GL@(I)) Q:'I S XI=^(I,"I"),XE=^("E") D Q:F4>2
. N CL,APPT,DATE,INST
. S APPT=+XI,CL=+$P(XI,U,2) Q:'CL
. S DATE=$P(APPT,".") Q:$D(@GL@("D",DATE)) S ^(DATE)=""
. S INST=+$$GET1^DIQ(44,SC,3,"I") Q:'INST
. I APPT>NOW D
. . S Y=1+$G(DIV("F",INST)) I Y>2 S F4=INST Q
. . S DIV("F",INST)=Y I '$D(DIV("F",0)) S DIV("F",0)=APPT_U_INST Q
. . I APPT<DIV("F",0) S DIV("F",0)=APPT_U_INST
. . Q
. I APPT'>NOW D
. . S Y=1+$G(DIV("P",INST)),DIV("F",INST)=Y
. . I '$D(DIV("P",0)) S DIV("F",0)=APPT_U_INST Q
. . I APPT>DIV("P",0) S DIV("F",0)=APPT_U_INST
. . Q
. Q
I 'F4 S (I,X,Y)=0 D
. F S I=$O(DIV("P",I)) Q:'I I DIV("P",I)>Y S X=I,Y=DIV("P",I)
. I X,Y>2 S F4=X Q
. S X=$G(DIV("F",0)) I +X S F4=$P(X,U,2) Q
. S X=$G(DIV("P",0)) I +X S F4=$P(X,U,2)
. Q
I F4 S F4=$P($$NS^XUAF4(F4),U)
K @GL
Q F4
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODEMSB 10797 printed Oct 16, 2024@18:27:30 Page 2
PSODEMSB ;EPIP/RTW - PSODEM subroutines ; 7/29/17 3:24pm
+1 ;;7.0;OUTPATIENT PHARMACY;**452,564,570,607,664**;Dec 1997;Build 6
+2 ;------------------------------------------------------------------
+3 ; External reference to $$OUTPTTM^SDUTL3 supported by ICR 1252
+4 ; External reference to ^DIE supported by ICR 2022
+5 ; External references to $$GET1^DIQ supported by ICR 2056
+6 ; External reference to ^PS(55 supported by ICR 2228
+7 ; External reference to $$GETALL^SCAPMCA supported by ICR 2848
+8 ; External reference to VST^ORWCV supported by ICR 4211
+9 ; External reference to $$SDAPI^SDMACA301 supported by ICR 4433
+10 ; External reference to ^DD("DILOCKTM" supported by ICR 4909
+11 ; External reference to ^DIC supported by ICR 10006
+12 ; External reference to ^DIR supported by ICR 10026
+13 ; External reference to ^DPT( supported by ICR 10035
+14 ; External reference to ^VA(200 supported by ICR 10060
+15 ; External reference to LOCK^DILF($NA( supported by ICR 2054
+16 ;------------------------------------------------------------------
DEMOG(PSODFN) ;
+1 ; Extend patient demographics with PC Team, Current Facility
+2 ; Remarks, and Clinical Alerts, pause the screen until <Enter>
+3 ; Input:
+4 ; DFN ; Required ; IEN of Patient file (#2) entry
+5 ;
+6 if $DATA(XQORNOD(0))
QUIT
+7 NEW PSOTEAM,PSOCLINA,DIR,DIRUT,PG,X,Y
+8 ; PSO*7*607
IF $GET(XQY0)["PSO P"
IF (IO=IO(0))
IF $EXTRACT(IOST)="C"
Begin DoDot:1
+9 WRITE !
+10 SET DIR("T")=DTIME
SET DIR(0)="EA"
SET DIR("A")="Press <Enter> to continue: "
DO ^DIR
End DoDot:1
+11 ;
+12 SET PG=0
+13 DO PCTEAM(PSODFN)
+14 IF 'PSOTEAM
WRITE !!
DO HDR("Extended Patient Demographics:")
+15 DO REMARKS(PSODFN)
+16 WRITE !?1,"Assigned/Recent Facility: ",$$CURRFAC(PSODFN)
+17 DO CA(PSODFN)
+18 if $DATA(DIRUT)
QUIT
+19 ;
IF $GET(XQY0)'["OR CPRS GUI CHART"
IF (IO=IO(0))
IF $EXTRACT(IOST)="C"
Begin DoDot:1
+20 WRITE !
+21 SET DIR("T")=DTIME
SET DIR(0)="EA"
SET DIR("A")="Press <Enter> to continue: "
DO ^DIR
End DoDot:1
+22 QUIT
+23 ;------------------------------------------------------------------
CA(PSODFN) ; Print PHARMACY PATIENT CLINICAL ALERTS multiple field (#2)
+1 ; Input:
+2 ; DFN ; Required ; IEN of Patient file (#2) entry
+3 ;
+4 NEW PSOFLAG1,PSODATER
+5 ;
+6 ; Quit, if no Patient IEN
if '$GET(PSODFN)
QUIT
+7 ; No CLINICAL ALERTS
if '$PIECE($GET(^PS(55,PSODFN,2,0)),U,4)
QUIT
+8 ;
+9 ; First time flag to display field header
SET PSOFLAG1=1
SET PSOCLINA=0
+10 ;
+11 ; PSODATER format DINUMed: 9999999.999999-CLINICAL ALERT DATE/TIME
+12 SET PSODATER=0
+13 ;
FOR
SET PSODATER=$ORDER(^PS(55,PSODFN,2,PSODATER))
if 'PSODATER
QUIT
Begin DoDot:1
+14 IF PSOFLAG1=1
WRITE !!,"Clinical Alerts:"
SET PSOFLAG1=0
+15 ; Display CLINICAL ALERT DATE/TIME (#.01) & CLINICAL ALERT (#1)
+16 WRITE !!,?2,$$GET1^DIQ(55.0109,PSODATER_","_PSODFN,.01)
+17 WRITE " ",$$GET1^DIQ(55.0109,PSODATER_","_PSODFN,1)
+18 IF '$GET(PAGE)!($Y+7>IOSL)
IF $ORDER(^PS(55,PSODFN,2,PSODATER))
DO HDR("Clinical Alerts:")
End DoDot:1
if $DATA(DIRUT)
QUIT
+19 QUIT
+20 ;------------------------------------------------------------------
HDR(HDR) ;
+1 NEW DIR
+2 ;p664 OPT=Option
IF '$DATA(OPT)
SET OPT=$GET(XQY0)
+3 WRITE !
+4 ;PSO*7*607
+5 IF PG
IF IO=IO(0)
IF $EXTRACT(IOST)="C"
SET DIR("T")=DTIME
SET DIR(0)="EA"
SET DIR("A")="Type <Enter> to continue or '^' to exit Clinical Alerts:"
DO ^DIR
IF $DATA(DIRUT)
QUIT
+6 ;P664
IF $GET(XQY0)["PSO LMOE FINISH"!($GET(XQY0)["PSO VIEW")
Begin DoDot:1
+7 IF $GET(OPT)'=$GET(XQY0)
SET PAGE=0
SET OPT=$GET(XQY0)
End DoDot:1
+8 IF HDR]""
WRITE @IOF
SET PAGE=$GET(PAGE)+1
WRITE HDR,?70,"Page: ",PAGE,!
SET $Y=1
+9 QUIT
CURRFAC(PSODFN) ; Return: The Assigned/Recent Facility INSTITUTION for the Patient's DFN
+1 ; Input:
+2 ; DFN ; Required ; IEN of Patient file (#2) entry
+3 ;
+4 NEW DATA,DTBEG,DTEND,FLAGQ,IEN4,ORVISIT,PCTEAM,PREVSCDT,RETURN,SUB
+5 ;
+6 ; Default return value is null
SET RETURN=""
+7 ;
+8 ; .351 Patient DATE OF DEATH
IF $$GET1^DIQ(2,PSODFN,.351,"I")
QUIT RETURN
+9 ;
+10 ; The first choice for returning the INSTITUTION would be the
+11 ; INSTITUTION field (#.07) of the TEAM file (#404.51)
+12 ;
+13 ; IEN^NAME of file (#404.51) ; ICR #1252
SET PCTEAM=$$OUTPTTM^SDUTL3(PSODFN,DT,1)
+14 ; *** End patch #1 change #1 by R2/Confer on 08/07/2015
+15 IF +PCTEAM>0
Begin DoDot:1
+16 ; INSTITUTION [R*P4']
SET RETURN=$$GET1^DIQ(404.51,+PCTEAM,.07)
End DoDot:1
QUIT RETURN
+17 ;
+18 ; Return future appointments and past visits for a patient
+19 ;
+20 ; Begin with TODAY - 2 years
SET DTBEG=DT-20000
+21 ; End with TODAY + 2 years
SET DTEND=DT+20000
+22 ; ICR #4211
DO VST^ORWCV(.ORVISIT,PSODFN,DTBEG,DTEND)
+23 ;
+24 ; Process ORVISIT array in reverse chronological order. Quantify
+25 ; visits & appointments based upon the INSTITUTION pointer field (#3)
+26 ; of the HOSPITAL LOCATION file (#44). Once the count reaches
+27 ; 3 for a given INSTITUTION, that INSTITUION is returned.
+28 ;
+29 ; Quit flag, set to 1 once the Institution is determined
SET FLAGQ=0
+30 ; Previous appt/visit date
SET PREVSCDT=""
+31 ;.... Sequential number of ORVISIT array subscript
SET SUB=":"
+32 ;
FOR
SET SUB=$ORDER(ORVISIT(SUB),-1)
if 'SUB!FLAGQ
QUIT
Begin DoDot:1
+33 NEW DATA,SC,SCDT
+34 SET DATA=ORVISIT(SUB)
+35 ; HOSPITAL LOCATION file (#44) IEN
SET SC=$PIECE($PIECE(DATA,U),";",3)
if 'SC
QUIT
+36 ; INSTITUTION file (#4) IEN
SET IEN4=+$$GET1^DIQ(44,SC,3,"I")
+37 ; Appt/visit date (fm format)
SET SCDT=$PIECE($PIECE(DATA,U),";",2)
if 'SCDT
QUIT
+38 ; Strip the time
SET SCDT=$PIECE(SCDT,".")
+39 ; Appt/visit must be a N day
if SCDT=PREVSCDT
QUIT
+40 ; Initialize INSTITUTION counter
IF '$DATA(IEN4(IEN4))
SET IEN4(IEN4)=0
+41 ; Quantify by INSTITUTION ien
SET IEN4(IEN4)=IEN4(IEN4)+1
+42 ; When count reaches 3, INSTITUTION found
IF IEN4(IEN4)=3
Begin DoDot:2
+43 ; INSTITUTION NAME (#.01)
SET RETURN=$$GET1^DIQ(4,IEN4,.01)
+44 SET FLAGQ=1
End DoDot:2
QUIT
+45 ;
+46 ; Save as previous appt/visit date
SET PREVSCDT=SCDT
End DoDot:1
+47 ;
+48 ; IF no PCTEAM INSTITUTION
+49 ; AND three appt/visits were not found for an INSTITUTION ien
+50 ; AND at least one appt/visit was found
+51 ; THEN
+52 ; return the most recent appt/visit INSTITUTION
+53 ;
+54 ;
IF RETURN=""
Begin DoDot:1
+55 NEW DATA,IEN4,SC,SUB
+56 SET SUB=$ORDER(ORVISIT(":"),-1)
if 'SUB
QUIT
+57 SET DATA=ORVISIT(SUB)
+58 ; HOSPITAL LOCATION file (#44) IEN
SET SC=$PIECE($PIECE(DATA,U),";",3)
if 'SC
QUIT
+59 ; INSTITUTION file (#4) IEN
SET IEN4=$$GET1^DIQ(44,SC,3,"I")
+60 ; INSTITUTION file (#4) NAME (#.01)
SET RETURN=$$GET1^DIQ(4,IEN4,.01)
End DoDot:1
+61 ;
+62 QUIT RETURN
+63 ;------------------------------------------------------------------
PCTEAM(PSODFN) ; Display current PC TEAM, PC Provider, and phone.
+1 ; Input:
+2 ; DFN ; Required ; IEN of Patient file (#2) entry
+3 ;
+4 SET PSOTEAM=0
+5 NEW DATA,PAGER,PCPOS,PCPROV,PCPROVI,PHONE,PCTM
+6 NEW SCDT2,SCP,SDI,TEAM,TEAMI
+7 ;
+8 SET PCTM="^TMP(""SDPLIST"",$J)"
+9 KILL @PCTM
+10 ; ICR #2848
SET SDI=$$GETALL^SCAPMCA(PSODFN,DT,PCTM)
if 'SDI
QUIT
+11 SET SDI=0
+12 ;
FOR
SET SDI=$ORDER(^TMP("SDPLIST",$JOB,PSODFN,"PCTM",SDI))
if 'SDI
QUIT
Begin DoDot:1
+13 ;
+14 ; "PCTM" node (PC Team)
+15 SET PSOTEAM=1
+16 SET DATA=$GET(^TMP("SDPLIST",$JOB,PSODFN,"PCTM",SDI))
if DATA=""
QUIT
+17 ; IEN of TEAM file (#404.51)
SET TEAMI=$PIECE(DATA,U,1)
+18 ;. NAME of TEAM file entry
SET TEAM=$PIECE(DATA,U,2)
+19 ;
+20 ; "PCPR" node (PC Provider)
+21 SET DATA=$GET(^TMP("SDPLIST",$JOB,PSODFN,"PCPR",SDI))
+22 ; IEN of PC Provider
SET PCPROVI=+$PIECE(DATA,U,1)
+23 ;. PC Provider
SET PCPROV=$PIECE(DATA,U,2)
+24 ;.. PC Provider Position
SET PCPOS=$PIECE(DATA,U,4)
+25 ; DIGITAL PAGER
SET PAGER=$$GET1^DIQ(200,PCPROVI,.138)
+26 ; VOICE PAGER
if PAGER=""
SET PAGER=$$GET1^DIQ(200,PCPROVI,.137)
+27 ; OFFICE PHONE
SET PHONE=$$GET1^DIQ(200,PCPROVI,.132)
+28 ;
+29 IF PSOTEAM
WRITE !!
DO HDR("Extended Patient Demographics:")
+30 ;
+31 WRITE !," Primary Care Team: ",TEAM
+32 ; TEAM PHONE NUMBER
WRITE ?52," Phone: ",$$GET1^DIQ(404.51,TEAMI,.02)
+33 ;
+34 WRITE !," PC Provider: ",PCPROV
+35 WRITE ?52,"Position: ",$EXTRACT(PCPOS,1,18)
+36 ;
+37 WRITE !?13,"Pager: ",PAGER
+38 WRITE ?52," Phone: ",PHONE
End DoDot:1
+39 ;
+40 KILL @PCTM
+41 QUIT
+42 ;------------------------------------------------------------------
+1 ; Input:
+2 ; DFN ; Required ; IEN of Patient file (#2) entry
+3 ;
+4 WRITE !?11,"Remarks: ",$$GET1^DIQ(2,PSODFN_",",.091)
+5 ;
+6 QUIT
+7 ;------------------------------------------------------------------
ENTER ; PSO CLINICAL ENTER/EDIT OPTION ENTRY POINT.
+1 NEW PSODFN
PROMPT ;
+1 WRITE @IOF,!?1,"*** CLINICAL ALERT ENTER/EDIT ***"
START ;
+1 WRITE !
+2 ; Prompt for Select PHARMACY PATIENT
SET PSODFN=+$$PATIENT
if 'PSODFN
GOTO EXIT
WRITE !
+3 ; Edit CLINICAL ALERTS (multiple)
DO EDITCA(PSODFN)
+4 GOTO START
+5 ;
EXIT ;
+1 QUIT
+2 ;------------------------------------------------------------------
EDITCA(PSODFN) ; Edit the CLINICAL ALERTS multiple (#109) of file (#55)
+1 ; Input:
+2 ; DFN ; Patient file (#2) entry internal entry number
+3 ;
+4 NEW %,%X,%Y,D,D0,D1,DA,DG,DI,DIC,DIDEL,DIE,DIERR,DIW,DQ,DR,DTOUT,X
+5 ;
+6 SET DA=PSODFN
+7 SET DIE="^PS(55,"
SET DR="[PSO CLINICAL ALERT ENTER/EDIT]"
+8 ;
+9 DO LOCK^DILF($NAME(^PS(55,DA)))
IF '$TEST
Begin DoDot:1
+10 WRITE $CHAR(7),!?4
+11 WRITE "Patient ",$$GET1^DIQ(2,DA,.01)," is being edited by another user."
End DoDot:1
QUIT
+12 DO ^DIE
+13 LOCK -^PS(55,DA)
+14 ;
+15 QUIT
+16 ;-----------------------------------------------------------------
PATIENT() ; Extrinsic, prompt for 'Select PHARMACY PATIENT: '
+1 ; Output:
+2 ; IEN^Name ; Of the selected Pharmacy Patient file #55 entry
+3 ; Return null if no patient selected
+4 ;
+5 NEW %,%H,%I,%X,%Y,C,D,D0,DA,DDH,DG,DIC,DILN,DINUM,DIPGM,DIY
+6 NEW DLAYGO,DTOUT,DUOUT,I,RETURN,X,Y
+7 ;
+8 SET RETURN=""
+9 SET DIC="^PS(55,"
+10 SET DIC(0)="AEMQZ"
+11 DO ^DIC
IF Y>0
SET RETURN=+Y_"^"_Y(0,0)
+12 ;
+13 QUIT RETURN
+14 ;
APPT() ; get appointments up to +/-2 yrs from now
+1 ; return null or name of institution
+2 ; ICR# 10061 - VADPT supported
+3 ; ICR# 10040 - FM read of file 44, field 3 supported
+4 ; ICR# 2171 - $$NS^XUAF4
+5 NEW I,X,Y,DIV,F4,GL,NOW,VAERR,VAST,XI,XE
+6 SET GL=$NAME(^UTILITY("VASD",$JOB))
KILL @GL
+7 SET NOW=$$NOW^XLFDT
+8 SET VASD("F")=DT-20000
+9 SET VASD("T")=DT+20000
+10 DO SDA^VADPT
+11 ; div("F",inst)=total count of visits
+12 ; div("F",0) = appt_dt ^ inst_ptr
+13 ; div("P") set up similarly for past kept appointments
+14 ; ^utility("VASD",$j,inc,"I"/"E")=appt_dt^clinic^status^appt_type
+15 ; only use one visit per day for division count
+16 ; if institution has more than 2 future appts, use that
+17 ; if institution has more than 2 past appts, use that
+18 ; if future appts, use institution of next appt
+19 ; if past appts, use institution of last appt
+20 ; use ^UTILITY("VASD",$J,"D",DATE)="" to track visit days
+21 SET F4=""
SET I=0
FOR
SET I=$ORDER(@GL@(I))
if 'I
QUIT
SET XI=^(I,"I")
SET XE=^("E")
Begin DoDot:1
+22 NEW CL,APPT,DATE,INST
+23 SET APPT=+XI
SET CL=+$PIECE(XI,U,2)
if 'CL
QUIT
+24 SET DATE=$PIECE(APPT,".")
if $DATA(@GL@("D",DATE))
QUIT
SET ^(DATE)=""
+25 SET INST=+$$GET1^DIQ(44,SC,3,"I")
if 'INST
QUIT
+26 IF APPT>NOW
Begin DoDot:2
+27 SET Y=1+$GET(DIV("F",INST))
IF Y>2
SET F4=INST
QUIT
+28 SET DIV("F",INST)=Y
IF '$DATA(DIV("F",0))
SET DIV("F",0)=APPT_U_INST
QUIT
+29 IF APPT<DIV("F",0)
SET DIV("F",0)=APPT_U_INST
+30 QUIT
End DoDot:2
+31 IF APPT'>NOW
Begin DoDot:2
+32 SET Y=1+$GET(DIV("P",INST))
SET DIV("F",INST)=Y
+33 IF '$DATA(DIV("P",0))
SET DIV("F",0)=APPT_U_INST
QUIT
+34 IF APPT>DIV("P",0)
SET DIV("F",0)=APPT_U_INST
+35 QUIT
End DoDot:2
+36 QUIT
End DoDot:1
if F4>2
QUIT
+37 IF 'F4
SET (I,X,Y)=0
Begin DoDot:1
+38 FOR
SET I=$ORDER(DIV("P",I))
if 'I
QUIT
IF DIV("P",I)>Y
SET X=I
SET Y=DIV("P",I)
+39 IF X
IF Y>2
SET F4=X
QUIT
+40 SET X=$GET(DIV("F",0))
IF +X
SET F4=$PIECE(X,U,2)
QUIT
+41 SET X=$GET(DIV("P",0))
IF +X
SET F4=$PIECE(X,U,2)
+42 QUIT
End DoDot:1
+43 IF F4
SET F4=$PIECE($$NS^XUAF4(F4),U)
+44 KILL @GL
+45 QUIT F4
