- 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 Feb 18, 2025@23:53:18 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