- 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 Jan 18, 2025@03:08:23 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 ;