PSJIMO1 ;BIR/LE - IMO UTILITIES AND XREFS ;16 Mar 99 / 10:22 AM
;;5.0;INPATIENT MEDICATIONS ;**257,299,311,307,335**;16 DEC 97;Build 6
;External reference to ^PS(55 supported by DBIA 2191
;External reference to ^PSSDSAPI supported by DBIA 5425
;External Reference to ^DPTLK is supported by DBIA 3787
;
IMO(CLINICS) ;called from ENCD^PSGFILED WHICH IS CLINIC DEFINITION OPTION IN INPATIENT MEDS
W !!,"Verifying IMO clinic cross references...",!
N CLINFLG,IMOCLIEN,PSJIMOCL,PSJCLIN,FLAG S FLAG=""
S (CLINFLG,CLINIC,PSJIMOCL,IMOCLIEN)=""
F S IMOCLIEN=$O(CLINICS(IMOCLIEN)) Q:IMOCLIEN="" S PSJIMOCL=$$GET1^DIQ(53.46,IMOCLIEN,.01,"I"),CLINFLG=$$GET1^DIQ(44,PSJIMOCL,2802,"I") D
.I 'CLINFLG D IMOKILL(PSJIMOCL,CLINFLG) Q ;CLINFLG=ADIMINISTER INPATIENT MEDS? true means IMO clinic; false means not IMO
.I CLINFLG D IMOSET(PSJIMOCL,CLINFLG,IMOCLIEN)
I FLAG W !,"IMO cross references have been updated.",!
Q
;
IMOSET(PSJCLIN,PSJIMOF,CLINIC) ;
;Clinic order means Yes is answered to ADMINISTER INPATIENT MEDS field in file 44, a clinic and appointment date/time is defined.
;Q:$D(^PS("CIMOCLU",CLINIC))!($D(^PS("CIMOCLI",CLINIC)))
N CLNDAYS,PSJAPTDT,PSJTODAY,X1,X2,PATIENT,PSJSTDT,PS55IEN,PS531IEN,PSJXREF,PSJTYPE,APPTDT,PSJUTMP,PSJSTART
S CLNDAYS=$$GET1^DIQ(53.46,CLINIC,6)
S:CLNDAYS="" CLNDAYS=30 ;default to 30 days if not defined
D NOW^%DTC S (X1,PSJTODAY)=%,X2=-CLNDAYS D C^%DTC S PSJSTART=X
;FILE 55
F PSJXREF="AUDC","AIVC" S PSJSTDT=PSJSTART F S PSJSTDT=$O(^PS(55,PSJXREF,PSJSTDT)) Q:PSJSTDT="" D
.S PATIENT="" F S PATIENT=$O(^PS(55,PSJXREF,PSJSTDT,PSJCLIN,PATIENT)) Q:PATIENT="" S PS55IEN="" F S PS55IEN=$O(^PS(55,PSJXREF,PSJSTDT,PSJCLIN,PATIENT,PS55IEN)) Q:PS55IEN="" D
..I PSJXREF="AUDC" S PSJAPTDT=$$GET1^DIQ(55.06,PS55IEN_","_PATIENT_",",131) I PSJAPTDT'="" S ^PS(55,"CIMOU",PATIENT,PSJCLIN,PSJSTDT,PATIENT,PS55IEN)=""
..I PSJXREF="AIVC" S PSJAPTDT=$$GET1^DIQ(55.01,PS55IEN_","_PATIENT_",",139) I PSJAPTDT'="" S ^PS(55,PATIENT,"IV","CIMOI",PSJCLIN,PSJSTDT,PS55IEN)=""
..I PSJAPTDT'="" S FLAG=1
;
;FILE 53.1
S (PATIENT,PS531IEN)=""
F S PATIENT=$O(^PS(53.1,"AD",PSJCLIN,PATIENT)) Q:PATIENT="" F S PS531IEN=$O(^PS(53.1,"AD",PSJCLIN,PATIENT,PS531IEN)) Q:PS531IEN="" D
.K PSJUTMP D GETS^DIQ(53.1,PS531IEN,"28;126","I","PSJUTMP")
.S (APPTDT,PSJTYPE)=""
.S:$D(PSJUTMP(53.1,PS531IEN_",",126,"I")) APPTDT=PSJUTMP(53.1,PS531IEN_",",126,"I")
.S:$D(PSJUTMP(53.1,PS531IEN_",",28,"I")) PSJTYPE=PSJUTMP(53.1,PS531IEN_",",28,"I")
.Q:PSJTYPE'="P"&(PSJTYPE'="N")
.Q:APPTDT=""!'CLINFLG
.S ^PS(53.1,"CIMO",PATIENT,PSJCLIN,PS531IEN)="",FLAG=1
Q
;
IMOKILL(CLINIC,PSCLINIC) ;
S:'$G(PSCLINIC) PSCLINIC=""
I $D(^PS(55,"CIMOCLU",CLINIC)) S PATIENT="" F S PATIENT=$O(^PS(55,"CIMOCLU",CLINIC,PATIENT)) Q:PATIENT="" D
.K ^PS(55,"CIMOU",PATIENT,CLINIC)
I $D(^PS(55,"CIMOCLI",CLINIC)) S PATIENT="" F S PATIENT=$O(^PS(55,"CIMOCLU",CLINIC,PATIENT)) Q:PATIENT="" D
.K ^PS(55,PATIENT,"IV","CIMOI",CLINIC)
K ^PS(55,"CIMOCLU",CLINIC),^PS(55,"CIMOCLI",CLINIC)
I $D(^PS(53.1,"AD",CLINIC)) S PATIENT="" F S PATIENT=$O(^PS(53.1,"AD",CLINIC,PATIENT)) Q:PATIENT="" D
.I $D(^PS(53.1,"CIMO",PATIENT,CLINIC)) K ^PS(53.1,"CIMO",PATIENT,CLINIC)
Q
;
CIMOU(PSGP,PSJDA55,PSCLINIC,PSJDA531) ;IMO UNIT DOSE FILE 55 CROSS REFERENCE SET
N PSJCLINI,CLINFLG,PSJIVIEN,PSJSTAT
I $G(PSJDA531)="" S PSJDA531=""
S PSJSTAT=""
I '$G(PSCLINIC) S PSCLINIC="",PSCLINIC=$$GET1^DIQ(55.06,+PSJDA55_","_PSGP_",",130,"I")
Q:PSCLINIC=""
S CLINFLG="",CLINFLG=$$GET1^DIQ(44,PSCLINIC,2802,"I") ;Only set xref if IMO clinic
Q:'CLINFLG
D GETS^DIQ(55.06,+PSJDA55_","_PSGP_",","34;131","I","PSJCLINI")
I CLINFLG&($G(PSJCLINI(55.06,+PSJDA55_","_PSGP_",","131","I"))) D
.S ^PS(55,"CIMOU",PSGP,PSCLINIC,PSJCLINI(55.06,+PSJDA55_","_PSGP_",","34","I"),PSGP,+PSJDA55)=""
.S ^PS(55,"CIMOCLU",PSCLINIC,PSGP,+PSJDA55)=""
S PSJIVIEN=$$GET1^DIQ(55.06,+PSJDA55_","_DFN_",",104) ;pick up ien from file 55 since PSJORD/PSGORD can't be trusted.
S:PSJIVIEN="" PSJIVIEN=PSJDA531
I $G(PSJIVIEN)]"",'$D(^PS(53.1,"CIMO",PSGP,PSCLINIC,PSJIVIEN)) S PSJIVIEN=PSJDA531 ;for edits, if no CIMO entry, use the passed in IEN. Non-edits will always have an entry.
I +$G(PSJIVIEN) D KILL531(PSGP,PSCLINIC,+PSJIVIEN)
Q
;
CIMOI(DFN,PSJDA55,PSCLINIC,PSJDA531) ;IMO IV FILE 55 CROSS REFERENCE SET
N PSJCLINI,CLINFLG,PSJIVIEN,PSJSTAT
S PSJSTAT=""
I '$G(PSCLINIC) S PSCLINIC=$$GET1^DIQ(55.01,+PSJDA55_","_DFN_",",136,"I")
Q:PSCLINIC=""
S CLINFLG="",CLINFLG=$$GET1^DIQ(44,PSCLINIC,2802,"I") ;Only set xref if IMO clinic
Q:'CLINFLG
D GETS^DIQ(55.01,+PSJDA55_","_DFN_",",".03","I","PSJCLINI")
I $D(PSJCLINI(55.01,+PSJDA55_","_DFN_",",".03","I")) D
.S ^PS(55,DFN,"IV","CIMOI",PSCLINIC,PSJCLINI(55.01,+PSJDA55_","_DFN_",",".03","I"),+PSJDA55)=""
.S ^PS(55,"CIMOCLI",PSCLINIC,DFN,+PSJDA55)=""
S PSJIVIEN=$$GET1^DIQ(55.01,+ON55_","_DFN_",",113) ;if there, pick up ien from file 55 since PSJORD/PSGORD can't be trusted.
I PSJIVIEN=""&(+$G(PSJDA531)) S PSJIVIEN=PSJDA531
;I '$D(^PS(53.1,"CIMO",PSGP,PSCLINIC,PSJIVIEN)) S PSJIVIEN=PSJDA531 ;for edits, if no CIMO entry, use the passed in IEN. Non-edits will always have an entry.
I +$G(PSJIVIEN) D KILL531(DFN,PSCLINIC,+PSJIVIEN)
Q
;
KILL531(PSJCLPAT,PSCLINIC,PSJIVIEN) ;
I '$G(PSCLINIC) S PSCLINIC=$$GET1^DIQ(53.1,+PSJIVIEN_","_PSJCLPAT_",",113,"I")
Q:PSCLINIC=""
I $D(^PS(53.1,"CIMO",PSJCLPAT,PSCLINIC,+PSJIVIEN)) K ^PS(53.1,"CIMO",PSJCLPAT,PSCLINIC,+PSJIVIEN)
Q
;
GETCLN(PSGP,ORDER) ; Return Clinic IEN for a given patient/order combination
I '$G(ORDER) Q ""
N CLN S CLN=$S(ORDER["P":$G(^PS(53.1,+ORDER,"DSS")),ORDER["V":$G(^PS(55,PSGP,"IV",+ORDER,"DSS")),ORDER["U":$G(^PS(55,PSGP,5,+ORDER,8)),1:"")
I 'CLN,(ORDER=+ORDER) D
.I $D(^PS(53.1,"ACX",+ORDER)) N PSJORD S PSJORD=0 F S PSJORD=$O(^PS(53.1,"ACX",+ORDER,PSJORD)) Q:'PSJORD!$G(CLN) S CLN=$G(^PS(53.1,+PSJORD,"DSS"))
.I $D(^PS(55,"ACX",+ORDER)) N ACX2,PSJORD S ACX2="" F S ACX2=$O(^PS(55,"ACX",+ORDER,ACX2)) Q:'ACX2!$G(CLN) S PSJORD=0 F S PSJORD=$O(^PS(55,"ACX",+ORDER,ACX2,PSJORD)) Q:'PSJORD!$G(CLN) D
..S CLN=$S(PSJORD["P":$G(^PS(53.1,+PSJORD,"DSS")),PSJORD["V":$G(^PS(55,PSGP,"IV",+PSJORD,"DSS")),ORDER["U":$G(^PS(55,PSGP,5,+PSJORD,8)),1:"")
Q +CLN
;
CHECK() ;SET CONDITION FOR CIMOU XREF IN FILE 55
;UNIT DOSE - X2(1)=PATIENT, X2(2)=CLINIC, X2(3)=STOP DATE
N PSJAPPTD,X S X=0
Q:'$$IMOCHK(X2(2)) 0 ;don't set clinic x-refs where clinic isn't marked as IMO.
S PSJAPPTD=$$GET1^DIQ(55.06,DA_","_X2(1)_",",131,"I")
S:PSJAPPTD'="" X=1
Q X
;
CHECK2() ;SET CONDITION FOR CIMOI XREF IN FILE 55
;IV - DA(1)=PATIENT, X2(1)=CLINIC, X2(2)=STOP DATE, DA=SUBFILE IEN
N PSJAPPTD,X S X=0
Q:'$$IMOCHK(X2(1)) 0 ;don't set clinic x-refs where clinic isn't marked as IMO.
S PSJAPPTD=$$GET1^DIQ(55.01,DA_","_DA(1)_",",139,"I")
S:PSJAPPTD'="" X=1
Q X
;
IMOCHK(PSJIMOCL) ;determine if clinic is an IMO clinic; returns 1 if IMO or 0 not IMO
Q:'$G(PSJIMOCL) 0
N PSJCFLAG
S PSJCFLAG=$$GET1^DIQ(44,PSJIMOCL,2802,"I")
Q PSJCFLAG
;
CHECK3() ;SET CONDITION FOR CIMO XREF IN FILE 53.1
; DA=IEN, X(1)=PATIENT, X(2)=CLINIC
N PSJCFLAG,PSJAPPTD,X,PSJTYPE,PSJUTMP S X=0
Q:'$$IMOCHK(X2(2)) 0 ;don't set clinic x-refs where clinic isn't marked as IMO.
D GETS^DIQ(53.1,DA,"28;126","I","PSJUTMP")
S X=0,(PSJAPPTD,PSJTYPE)=""
S:$D(PSJUTMP(53.1,DA_",",126,"I")) PSJAPPTD=PSJUTMP(53.1,DA_",",126,"I")
S:$D(PSJUTMP(53.1,DA_",",28,"I")) PSJTYPE=PSJUTMP(53.1,DA_",",28,"I")
Q:PSJTYPE'="P"&(PSJTYPE'="N") 0 ;only pending and non-verified orders are allowed in the xref
S:PSJAPPTD'="" X=1
Q X
;
TEST ;KILL ALL IMO CROSS REFERENCES FOR A PARTICULAR CLINIC AND PATIENT
N PSJTESCL,PSJTESPA
TEST2 ;
K DIC S DIC="^PS(53.46,",DIC(0)="AELMQ",DIC("A")="Select CLINIC: ",DLAYGO=53.46 D ^DIC K DIC G DONE:Y=""!(Y<1)
S PSJTESCL=$P(Y,"^",2)
K DIC,PSGP,Y W !!,"Select "_$S($D(PSGDICA):PSGDICA_" ",1:"")_"PATIENT: " R X:DTIME S:'$T X="^" W:'$T $C(7) I "^"[X S (Y,PSGP)=-1 S QFLG=1 G DONE
K DIC S DIC="^DPT(",DIC("W")="D DPT^PSJDPT",DIC(0)="QEMZ" D ^DPTLK K DIC
S PSJTESPA=$P(Y,"^")
;
K ^PS(55,PSJTESPA,"IV","CIMOI",PSJTESCL)
K ^PS(55,"CIMOCLI",PSJTESCL)
K ^PS(55,"CIMOU",PSJTESPA,PSJTESCL)
K ^PS(55,"CIMOCLU",PSJTESCL)
K ^PS(53.1,"CIMO",PSJTESPA,PSJTESCL)
W !,"DELETED",!
DONE ;
Q
;
CLEAN(DFN) ;Delete old entriers from clinic order xref; CALLED WHEN USER EXITS PATIENT IN IOE
;----get top of the range of dates stored for each clinic
N PSCLINIC,PSTYPE,ENDDATE,RXDATE,CLNDAYS,CLNARRY,PSJIEN
S (PSTYPE,PSCLINIC,CLNDAYS,CLNARRY)=""
F PSTYPE="CIMOCLU","CIMOCLI" F S PSCLINIC=$O(^PS(55,PSTYPE,PSCLINIC)) Q:PSCLINIC="" D
.S CLNDAYS=$$GET1^DIQ(53.46,PSCLINIC,6) S:CLNDAYS="" CLNDAYS=30 ;default to 30 days if not defined
.D NOW^%DTC S X1=%,X2=-CLNDAYS D C^%DTC S CLNARRY($S(PSTYPE="CIMOCLU":"U",1:"V"),PSCLINIC)=X
;----kill x-refs for all unit dose entries older than the clinic begin date
I $D(CLNARRY("U")) S PSCLINIC="" F S PSCLINIC=$O(CLNARRY("U",PSCLINIC)) Q:PSCLINIC="" D
.S (RXDATE,ENDDATE)="",ENDDATE=CLNARRY("U",PSCLINIC)
.F S RXDATE=$O(^PS(55,"CIMOU",DFN,PSCLINIC,RXDATE)) Q:RXDATE="" I RXDATE<ENDDATE K ^PS(55,"CIMOU",DFN,PSCLINIC,RXDATE) D
..S PSJIEN="" F S PSJIEN=$O(^PS(55,"CIMOU",DFN,PSCLINIC,RXDATE,DFN,PSJIEN)) Q:PSJIEN="" K ^PS(55,"CIMOU",DFN,PSCLINIC,RXDATE,DFN,PSJIEN)
;----kill x-refs for all IV entries older than the clinic begin date
I $D(CLNARRY("V")) S PSCLINIC="" F S PSCLINIC=$O(CLNARRY("V",PSCLINIC)) Q:PSCLINIC="" D
.S (RXDATE,ENDDATE)="",ENDDATE=CLNARRY("V",PSCLINIC)
.F S RXDATE=$O(^PS(55,DFN,"IV","CIMOI",PSCLINIC,RXDATE)) Q:RXDATE="" I RXDATE<ENDDATE K ^PS(55,DFN,"IV","CIMOI",PSCLINIC,RXDATE) D
..S PSJIEN="" F S PSJIEN=$O(^PS(55,DFN,"IV","CIMOI",PSCLINIC,RXDATE,PSJIEN)) Q:PSJIEN="" K ^PS(55,DFN,"IV","CIMOI",PSCLINIC,RXDATE,PSJIEN)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJIMO1 9877 printed Sep 23, 2025@19:43:17 Page 2
PSJIMO1 ;BIR/LE - IMO UTILITIES AND XREFS ;16 Mar 99 / 10:22 AM
+1 ;;5.0;INPATIENT MEDICATIONS ;**257,299,311,307,335**;16 DEC 97;Build 6
+2 ;External reference to ^PS(55 supported by DBIA 2191
+3 ;External reference to ^PSSDSAPI supported by DBIA 5425
+4 ;External Reference to ^DPTLK is supported by DBIA 3787
+5 ;
IMO(CLINICS) ;called from ENCD^PSGFILED WHICH IS CLINIC DEFINITION OPTION IN INPATIENT MEDS
+1 WRITE !!,"Verifying IMO clinic cross references...",!
+2 NEW CLINFLG,IMOCLIEN,PSJIMOCL,PSJCLIN,FLAG
SET FLAG=""
+3 SET (CLINFLG,CLINIC,PSJIMOCL,IMOCLIEN)=""
+4 FOR
SET IMOCLIEN=$ORDER(CLINICS(IMOCLIEN))
if IMOCLIEN=""
QUIT
SET PSJIMOCL=$$GET1^DIQ(53.46,IMOCLIEN,.01,"I")
SET CLINFLG=$$GET1^DIQ(44,PSJIMOCL,2802,"I")
Begin DoDot:1
+5 ;CLINFLG=ADIMINISTER INPATIENT MEDS? true means IMO clinic; false means not IMO
IF 'CLINFLG
DO IMOKILL(PSJIMOCL,CLINFLG)
QUIT
+6 IF CLINFLG
DO IMOSET(PSJIMOCL,CLINFLG,IMOCLIEN)
End DoDot:1
+7 IF FLAG
WRITE !,"IMO cross references have been updated.",!
+8 QUIT
+9 ;
IMOSET(PSJCLIN,PSJIMOF,CLINIC) ;
+1 ;Clinic order means Yes is answered to ADMINISTER INPATIENT MEDS field in file 44, a clinic and appointment date/time is defined.
+2 ;Q:$D(^PS("CIMOCLU",CLINIC))!($D(^PS("CIMOCLI",CLINIC)))
+3 NEW CLNDAYS,PSJAPTDT,PSJTODAY,X1,X2,PATIENT,PSJSTDT,PS55IEN,PS531IEN,PSJXREF,PSJTYPE,APPTDT,PSJUTMP,PSJSTART
+4 SET CLNDAYS=$$GET1^DIQ(53.46,CLINIC,6)
+5 ;default to 30 days if not defined
if CLNDAYS=""
SET CLNDAYS=30
+6 DO NOW^%DTC
SET (X1,PSJTODAY)=%
SET X2=-CLNDAYS
DO C^%DTC
SET PSJSTART=X
+7 ;FILE 55
+8 FOR PSJXREF="AUDC","AIVC"
SET PSJSTDT=PSJSTART
FOR
SET PSJSTDT=$ORDER(^PS(55,PSJXREF,PSJSTDT))
if PSJSTDT=""
QUIT
Begin DoDot:1
+9 SET PATIENT=""
FOR
SET PATIENT=$ORDER(^PS(55,PSJXREF,PSJSTDT,PSJCLIN,PATIENT))
if PATIENT=""
QUIT
SET PS55IEN=""
FOR
SET PS55IEN=$ORDER(^PS(55,PSJXREF,PSJSTDT,PSJCLIN,PATIENT,PS55IEN))
if PS55IEN=""
QUIT
Begin DoDot:2
+10 IF PSJXREF="AUDC"
SET PSJAPTDT=$$GET1^DIQ(55.06,PS55IEN_","_PATIENT_",",131)
IF PSJAPTDT'=""
SET ^PS(55,"CIMOU",PATIENT,PSJCLIN,PSJSTDT,PATIENT,PS55IEN)=""
+11 IF PSJXREF="AIVC"
SET PSJAPTDT=$$GET1^DIQ(55.01,PS55IEN_","_PATIENT_",",139)
IF PSJAPTDT'=""
SET ^PS(55,PATIENT,"IV","CIMOI",PSJCLIN,PSJSTDT,PS55IEN)=""
+12 IF PSJAPTDT'=""
SET FLAG=1
End DoDot:2
End DoDot:1
+13 ;
+14 ;FILE 53.1
+15 SET (PATIENT,PS531IEN)=""
+16 FOR
SET PATIENT=$ORDER(^PS(53.1,"AD",PSJCLIN,PATIENT))
if PATIENT=""
QUIT
FOR
SET PS531IEN=$ORDER(^PS(53.1,"AD",PSJCLIN,PATIENT,PS531IEN))
if PS531IEN=""
QUIT
Begin DoDot:1
+17 KILL PSJUTMP
DO GETS^DIQ(53.1,PS531IEN,"28;126","I","PSJUTMP")
+18 SET (APPTDT,PSJTYPE)=""
+19 if $DATA(PSJUTMP(53.1,PS531IEN_",",126,"I"))
SET APPTDT=PSJUTMP(53.1,PS531IEN_",",126,"I")
+20 if $DATA(PSJUTMP(53.1,PS531IEN_",",28,"I"))
SET PSJTYPE=PSJUTMP(53.1,PS531IEN_",",28,"I")
+21 if PSJTYPE'="P"&(PSJTYPE'="N")
QUIT
+22 if APPTDT=""!'CLINFLG
QUIT
+23 SET ^PS(53.1,"CIMO",PATIENT,PSJCLIN,PS531IEN)=""
SET FLAG=1
End DoDot:1
+24 QUIT
+25 ;
IMOKILL(CLINIC,PSCLINIC) ;
+1 if '$GET(PSCLINIC)
SET PSCLINIC=""
+2 IF $DATA(^PS(55,"CIMOCLU",CLINIC))
SET PATIENT=""
FOR
SET PATIENT=$ORDER(^PS(55,"CIMOCLU",CLINIC,PATIENT))
if PATIENT=""
QUIT
Begin DoDot:1
+3 KILL ^PS(55,"CIMOU",PATIENT,CLINIC)
End DoDot:1
+4 IF $DATA(^PS(55,"CIMOCLI",CLINIC))
SET PATIENT=""
FOR
SET PATIENT=$ORDER(^PS(55,"CIMOCLU",CLINIC,PATIENT))
if PATIENT=""
QUIT
Begin DoDot:1
+5 KILL ^PS(55,PATIENT,"IV","CIMOI",CLINIC)
End DoDot:1
+6 KILL ^PS(55,"CIMOCLU",CLINIC),^PS(55,"CIMOCLI",CLINIC)
+7 IF $DATA(^PS(53.1,"AD",CLINIC))
SET PATIENT=""
FOR
SET PATIENT=$ORDER(^PS(53.1,"AD",CLINIC,PATIENT))
if PATIENT=""
QUIT
Begin DoDot:1
+8 IF $DATA(^PS(53.1,"CIMO",PATIENT,CLINIC))
KILL ^PS(53.1,"CIMO",PATIENT,CLINIC)
End DoDot:1
+9 QUIT
+10 ;
CIMOU(PSGP,PSJDA55,PSCLINIC,PSJDA531) ;IMO UNIT DOSE FILE 55 CROSS REFERENCE SET
+1 NEW PSJCLINI,CLINFLG,PSJIVIEN,PSJSTAT
+2 IF $GET(PSJDA531)=""
SET PSJDA531=""
+3 SET PSJSTAT=""
+4 IF '$GET(PSCLINIC)
SET PSCLINIC=""
SET PSCLINIC=$$GET1^DIQ(55.06,+PSJDA55_","_PSGP_",",130,"I")
+5 if PSCLINIC=""
QUIT
+6 ;Only set xref if IMO clinic
SET CLINFLG=""
SET CLINFLG=$$GET1^DIQ(44,PSCLINIC,2802,"I")
+7 if 'CLINFLG
QUIT
+8 DO GETS^DIQ(55.06,+PSJDA55_","_PSGP_",","34;131","I","PSJCLINI")
+9 IF CLINFLG&($GET(PSJCLINI(55.06,+PSJDA55_","_PSGP_",","131","I")))
Begin DoDot:1
+10 SET ^PS(55,"CIMOU",PSGP,PSCLINIC,PSJCLINI(55.06,+PSJDA55_","_PSGP_",","34","I"),PSGP,+PSJDA55)=""
+11 SET ^PS(55,"CIMOCLU",PSCLINIC,PSGP,+PSJDA55)=""
End DoDot:1
+12 ;pick up ien from file 55 since PSJORD/PSGORD can't be trusted.
SET PSJIVIEN=$$GET1^DIQ(55.06,+PSJDA55_","_DFN_",",104)
+13 if PSJIVIEN=""
SET PSJIVIEN=PSJDA531
+14 ;for edits, if no CIMO entry, use the passed in IEN. Non-edits will always have an entry.
IF $GET(PSJIVIEN)]""
IF '$DATA(^PS(53.1,"CIMO",PSGP,PSCLINIC,PSJIVIEN))
SET PSJIVIEN=PSJDA531
+15 IF +$GET(PSJIVIEN)
DO KILL531(PSGP,PSCLINIC,+PSJIVIEN)
+16 QUIT
+17 ;
CIMOI(DFN,PSJDA55,PSCLINIC,PSJDA531) ;IMO IV FILE 55 CROSS REFERENCE SET
+1 NEW PSJCLINI,CLINFLG,PSJIVIEN,PSJSTAT
+2 SET PSJSTAT=""
+3 IF '$GET(PSCLINIC)
SET PSCLINIC=$$GET1^DIQ(55.01,+PSJDA55_","_DFN_",",136,"I")
+4 if PSCLINIC=""
QUIT
+5 ;Only set xref if IMO clinic
SET CLINFLG=""
SET CLINFLG=$$GET1^DIQ(44,PSCLINIC,2802,"I")
+6 if 'CLINFLG
QUIT
+7 DO GETS^DIQ(55.01,+PSJDA55_","_DFN_",",".03","I","PSJCLINI")
+8 IF $DATA(PSJCLINI(55.01,+PSJDA55_","_DFN_",",".03","I"))
Begin DoDot:1
+9 SET ^PS(55,DFN,"IV","CIMOI",PSCLINIC,PSJCLINI(55.01,+PSJDA55_","_DFN_",",".03","I"),+PSJDA55)=""
+10 SET ^PS(55,"CIMOCLI",PSCLINIC,DFN,+PSJDA55)=""
End DoDot:1
+11 ;if there, pick up ien from file 55 since PSJORD/PSGORD can't be trusted.
SET PSJIVIEN=$$GET1^DIQ(55.01,+ON55_","_DFN_",",113)
+12 IF PSJIVIEN=""&(+$GET(PSJDA531))
SET PSJIVIEN=PSJDA531
+13 ;I '$D(^PS(53.1,"CIMO",PSGP,PSCLINIC,PSJIVIEN)) S PSJIVIEN=PSJDA531 ;for edits, if no CIMO entry, use the passed in IEN. Non-edits will always have an entry.
+14 IF +$GET(PSJIVIEN)
DO KILL531(DFN,PSCLINIC,+PSJIVIEN)
+15 QUIT
+16 ;
KILL531(PSJCLPAT,PSCLINIC,PSJIVIEN) ;
+1 IF '$GET(PSCLINIC)
SET PSCLINIC=$$GET1^DIQ(53.1,+PSJIVIEN_","_PSJCLPAT_",",113,"I")
+2 if PSCLINIC=""
QUIT
+3 IF $DATA(^PS(53.1,"CIMO",PSJCLPAT,PSCLINIC,+PSJIVIEN))
KILL ^PS(53.1,"CIMO",PSJCLPAT,PSCLINIC,+PSJIVIEN)
+4 QUIT
+5 ;
GETCLN(PSGP,ORDER) ; Return Clinic IEN for a given patient/order combination
+1 IF '$GET(ORDER)
QUIT ""
+2 NEW CLN
SET CLN=$SELECT(ORDER["P":$GET(^PS(53.1,+ORDER,"DSS")),ORDER["V":$GET(^PS(55,PSGP,"IV",+ORDER,"DSS")),ORDER["U":$GET(^PS(55,PSGP,5,+ORDER,8)),1:"")
+3 IF 'CLN
IF (ORDER=+ORDER)
Begin DoDot:1
+4 IF $DATA(^PS(53.1,"ACX",+ORDER))
NEW PSJORD
SET PSJORD=0
FOR
SET PSJORD=$ORDER(^PS(53.1,"ACX",+ORDER,PSJORD))
if 'PSJORD!$GET(CLN)
QUIT
SET CLN=$GET(^PS(53.1,+PSJORD,"DSS"))
+5 IF $DATA(^PS(55,"ACX",+ORDER))
NEW ACX2,PSJORD
SET ACX2=""
FOR
SET ACX2=$ORDER(^PS(55,"ACX",+ORDER,ACX2))
if 'ACX2!$GET(CLN)
QUIT
SET PSJORD=0
FOR
SET PSJORD=$ORDER(^PS(55,"ACX",+ORDER,ACX2,PSJORD))
if 'PSJORD!$GET(CLN)
QUIT
Begin DoDot:2
+6 SET CLN=$SELECT(PSJORD["P":$GET(^PS(53.1,+PSJORD,"DSS")),PSJORD["V":$GET(^PS(55,PSGP,"IV",+PSJORD,"DSS")),ORDER["U":$GET(^PS(55,PSGP,5,+PSJORD,8)),1:"")
End DoDot:2
End DoDot:1
+7 QUIT +CLN
+8 ;
CHECK() ;SET CONDITION FOR CIMOU XREF IN FILE 55
+1 ;UNIT DOSE - X2(1)=PATIENT, X2(2)=CLINIC, X2(3)=STOP DATE
+2 NEW PSJAPPTD,X
SET X=0
+3 ;don't set clinic x-refs where clinic isn't marked as IMO.
if '$$IMOCHK(X2(2))
QUIT 0
+4 SET PSJAPPTD=$$GET1^DIQ(55.06,DA_","_X2(1)_",",131,"I")
+5 if PSJAPPTD'=""
SET X=1
+6 QUIT X
+7 ;
CHECK2() ;SET CONDITION FOR CIMOI XREF IN FILE 55
+1 ;IV - DA(1)=PATIENT, X2(1)=CLINIC, X2(2)=STOP DATE, DA=SUBFILE IEN
+2 NEW PSJAPPTD,X
SET X=0
+3 ;don't set clinic x-refs where clinic isn't marked as IMO.
if '$$IMOCHK(X2(1))
QUIT 0
+4 SET PSJAPPTD=$$GET1^DIQ(55.01,DA_","_DA(1)_",",139,"I")
+5 if PSJAPPTD'=""
SET X=1
+6 QUIT X
+7 ;
IMOCHK(PSJIMOCL) ;determine if clinic is an IMO clinic; returns 1 if IMO or 0 not IMO
+1 if '$GET(PSJIMOCL)
QUIT 0
+2 NEW PSJCFLAG
+3 SET PSJCFLAG=$$GET1^DIQ(44,PSJIMOCL,2802,"I")
+4 QUIT PSJCFLAG
+5 ;
CHECK3() ;SET CONDITION FOR CIMO XREF IN FILE 53.1
+1 ; DA=IEN, X(1)=PATIENT, X(2)=CLINIC
+2 NEW PSJCFLAG,PSJAPPTD,X,PSJTYPE,PSJUTMP
SET X=0
+3 ;don't set clinic x-refs where clinic isn't marked as IMO.
if '$$IMOCHK(X2(2))
QUIT 0
+4 DO GETS^DIQ(53.1,DA,"28;126","I","PSJUTMP")
+5 SET X=0
SET (PSJAPPTD,PSJTYPE)=""
+6 if $DATA(PSJUTMP(53.1,DA_",",126,"I"))
SET PSJAPPTD=PSJUTMP(53.1,DA_",",126,"I")
+7 if $DATA(PSJUTMP(53.1,DA_",",28,"I"))
SET PSJTYPE=PSJUTMP(53.1,DA_",",28,"I")
+8 ;only pending and non-verified orders are allowed in the xref
if PSJTYPE'="P"&(PSJTYPE'="N")
QUIT 0
+9 if PSJAPPTD'=""
SET X=1
+10 QUIT X
+11 ;
TEST ;KILL ALL IMO CROSS REFERENCES FOR A PARTICULAR CLINIC AND PATIENT
+1 NEW PSJTESCL,PSJTESPA
TEST2 ;
+1 KILL DIC
SET DIC="^PS(53.46,"
SET DIC(0)="AELMQ"
SET DIC("A")="Select CLINIC: "
SET DLAYGO=53.46
DO ^DIC
KILL DIC
if Y=""!(Y<1)
GOTO DONE
+2 SET PSJTESCL=$PIECE(Y,"^",2)
+3 KILL DIC,PSGP,Y
WRITE !!,"Select "_$SELECT($DATA(PSGDICA):PSGDICA_" ",1:"")_"PATIENT: "
READ X:DTIME
if '$TEST
SET X="^"
if '$TEST
WRITE $CHAR(7)
IF "^"[X
SET (Y,PSGP)=-1
SET QFLG=1
GOTO DONE
+4 KILL DIC
SET DIC="^DPT("
SET DIC("W")="D DPT^PSJDPT"
SET DIC(0)="QEMZ"
DO ^DPTLK
KILL DIC
+5 SET PSJTESPA=$PIECE(Y,"^")
+6 ;
+7 KILL ^PS(55,PSJTESPA,"IV","CIMOI",PSJTESCL)
+8 KILL ^PS(55,"CIMOCLI",PSJTESCL)
+9 KILL ^PS(55,"CIMOU",PSJTESPA,PSJTESCL)
+10 KILL ^PS(55,"CIMOCLU",PSJTESCL)
+11 KILL ^PS(53.1,"CIMO",PSJTESPA,PSJTESCL)
+12 WRITE !,"DELETED",!
DONE ;
+1 QUIT
+2 ;
CLEAN(DFN) ;Delete old entriers from clinic order xref; CALLED WHEN USER EXITS PATIENT IN IOE
+1 ;----get top of the range of dates stored for each clinic
+2 NEW PSCLINIC,PSTYPE,ENDDATE,RXDATE,CLNDAYS,CLNARRY,PSJIEN
+3 SET (PSTYPE,PSCLINIC,CLNDAYS,CLNARRY)=""
+4 FOR PSTYPE="CIMOCLU","CIMOCLI"
FOR
SET PSCLINIC=$ORDER(^PS(55,PSTYPE,PSCLINIC))
if PSCLINIC=""
QUIT
Begin DoDot:1
+5 ;default to 30 days if not defined
SET CLNDAYS=$$GET1^DIQ(53.46,PSCLINIC,6)
if CLNDAYS=""
SET CLNDAYS=30
+6 DO NOW^%DTC
SET X1=%
SET X2=-CLNDAYS
DO C^%DTC
SET CLNARRY($SELECT(PSTYPE="CIMOCLU":"U",1:"V"),PSCLINIC)=X
End DoDot:1
+7 ;----kill x-refs for all unit dose entries older than the clinic begin date
+8 IF $DATA(CLNARRY("U"))
SET PSCLINIC=""
FOR
SET PSCLINIC=$ORDER(CLNARRY("U",PSCLINIC))
if PSCLINIC=""
QUIT
Begin DoDot:1
+9 SET (RXDATE,ENDDATE)=""
SET ENDDATE=CLNARRY("U",PSCLINIC)
+10 FOR
SET RXDATE=$ORDER(^PS(55,"CIMOU",DFN,PSCLINIC,RXDATE))
if RXDATE=""
QUIT
IF RXDATE<ENDDATE
KILL ^PS(55,"CIMOU",DFN,PSCLINIC,RXDATE)
Begin DoDot:2
+11 SET PSJIEN=""
FOR
SET PSJIEN=$ORDER(^PS(55,"CIMOU",DFN,PSCLINIC,RXDATE,DFN,PSJIEN))
if PSJIEN=""
QUIT
KILL ^PS(55,"CIMOU",DFN,PSCLINIC,RXDATE,DFN,PSJIEN)
End DoDot:2
End DoDot:1
+12 ;----kill x-refs for all IV entries older than the clinic begin date
+13 IF $DATA(CLNARRY("V"))
SET PSCLINIC=""
FOR
SET PSCLINIC=$ORDER(CLNARRY("V",PSCLINIC))
if PSCLINIC=""
QUIT
Begin DoDot:1
+14 SET (RXDATE,ENDDATE)=""
SET ENDDATE=CLNARRY("V",PSCLINIC)
+15 FOR
SET RXDATE=$ORDER(^PS(55,DFN,"IV","CIMOI",PSCLINIC,RXDATE))
if RXDATE=""
QUIT
IF RXDATE<ENDDATE
KILL ^PS(55,DFN,"IV","CIMOI",PSCLINIC,RXDATE)
Begin DoDot:2
+16 SET PSJIEN=""
FOR
SET PSJIEN=$ORDER(^PS(55,DFN,"IV","CIMOI",PSCLINIC,RXDATE,PSJIEN))
if PSJIEN=""
QUIT
KILL ^PS(55,DFN,"IV","CIMOI",PSCLINIC,RXDATE,PSJIEN)
End DoDot:2
End DoDot:1
+17 QUIT
+18 ;
