BQIDCAH6 ;GDIT/HS/ALA-Ad Hoc Logic ; 26 Apr 2013 11:00 AM
;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
;
ALGY(FGLOB,TGLOB,BEN,MPARMS) ;EP - Allergy search
NEW ALGPT,AIEN,ACT,AL,CT,LIEN
I $G(TGLOB)="" Q
I $G(ALNAS)'="" D ANAS Q
I $G(ALNKN)'="" D NKNN Q
I $G(ALLERGY)]"" D ALGY1
I $D(MPARMS("ALLERGY")) D
. I ALLOP="!" D Q
.. S ALLERGY="" F S ALLERGY=$O(MPARMS("ALLERGY",ALLERGY)) Q:ALLERGY="" D ALGY1
. I ALLOP="&" D
.. S ALLERGY="",CT=0
.. F S ALLERGY=$O(MPARMS("ALLERGY",ALLERGY)) Q:ALLERGY="" S CT=CT+1
.. F S ALLERGY=$O(MPARMS("ALLERGY",ALLERGY)) Q:ALLERGY="" D ALGY1
.. I ALLOP="&" D
... S IEN=""
... F S IEN=$O(ALGPT(IEN)) Q:IEN="" D
.... S ACT=0,AL=""
.... F S AL=$O(ALGPT(IEN,AL)) Q:AL="" S ACT=ACT+1
.... I ACT'=CT K @CRIT@("ALGY",IEN) Q
.... S AL="" F S AL=$O(ALGPT(IEN,AL)) Q:AL="" S @TGLOB@(IEN)="",LIEN=ALGPT(IEN,AL),@CRIT@("ALGY",IEN,LIEN)=""
K ALGPT
Q
;
ALGY1 ;EP
NEW IEN,ALGTX,AN,DFN,TALLG
I $G(FGLOB)'="" D Q
. S IEN=""
. F S IEN=$O(@FGLOB@(IEN)) Q:'IEN D
.. S AN=""
.. F S AN=$O(^GMR(120.8,"B",IEN,AN)) Q:AN="" D
... ; If ENTERED IN ERROR, ignore
... I $$GET1^DIQ(120.8,AN_",",22,"I")=1 Q
... S ALGTX=$$GET1^DIQ(120.8,AN_",",.02,"E")
... I $E(ALGTX,$L(ALGTX),$L(ALGTX))=" " S ALGTX=$$STRIP^BQIUL1(ALGTX," ")
... I ALGTX=ALLERGY D
.... I ALLOP="!" S @TGLOB@(IEN)="",@CRIT@("ALGY",IEN,AN)=AN Q
.... S ALGPT(IEN,AN)=AN
;
I $L(ALLERGY)'>30 D
. NEW ALGTX,TXT
. S IEN=""
. F S IEN=$O(^GMR(120.8,"C",ALLERGY,IEN)) Q:IEN="" D ALCK
. S ALGTX=$O(^GMR(120.8,"C",ALLERGY)),TXT=ALLERGY_" "
. I ALGTX=TXT D
.. F S IEN=$O(^GMR(120.8,"C",ALGTX,IEN)) Q:IEN="" D ALCK
;
I $L(ALLERGY)>30 D
. S TALLG=ALLERGY
. F S TALLG=$O(^GMR(120.8,"C",TALLG)) Q:TALLG=""!($E(ALLERGY,1,30)'=$E(TALLG,1,30)) D
.. S IEN=""
.. F S IEN=$O(^GMR(120.8,"C",TALLG,IEN)) Q:IEN="" D ALCK
Q
;
ALCK ;EP
I $$GET1^DIQ(120.8,IEN_",",22,"I")=1 Q
S DFN=$$GET1^DIQ(120.8,IEN_",",.01,"I")
I ALLOP="!" S @TGLOB@(DFN)="",@CRIT@("ALGY",DFN,IEN)=IEN Q
S ALGPT(DFN,IEN)=IEN
Q
;
ANAS ;EP - No allergy assessment
NEW ADATA,IEN
I $G(FGLOB)'="" D Q
. S IEN=""
. F S IEN=$O(@FGLOB@(IEN)) Q:'IEN D
.. D DETAIL^BEHOCACV(.ADATA,IEN)
.. I $G(@ADATA@(1))="No allergy assessment." S @TGLOB@(IEN)=""
I $G(FGLOB)="" D Q
. S IEN=0
. F S IEN=$O(^AUPNPAT(IEN)) Q:'IEN D
.. I $D(^AUPNPAT(IEN,-9)) Q
.. D DETAIL^BEHOCACV(.ADATA,IEN)
.. I $G(@ADATA@(1))="No allergy assessment." S @TGLOB@(IEN)=""
Q
;
NKNN ;EP - No known allergy
NEW ADATA,IEN
I $G(FGLOB)'="" D Q
. S IEN=""
. F S IEN=$O(@FGLOB@(IEN)) Q:'IEN D
.. D DETAIL^BEHOCACV(.ADATA,IEN)
.. I $G(@ADATA@(1))="No known allergies." S @TGLOB@(IEN)=""
I $G(FGLOB)="" D Q
. S IEN=0
. F S IEN=$O(^AUPNPAT(IEN)) Q:'IEN D
.. I $D(^AUPNPAT(IEN,-9)) Q
.. D DETAIL^BEHOCACV(.ADATA,IEN)
.. I $G(@ADATA@(1))="No known allergies." S @TGLOB@(IEN)=""
Q
;
REM(FGLOB,TGLOB,REMCODE,RMFROM,RMTHRU,OVD,FUT,MPARMS) ;EP
I $G(TGLOB)="" Q
I $G(REMCODE)'="" D RMD
I $D(MPARMS("REMCODE")) D
. S REMCODE=""
. F S REMCODE=$O(MPARMS("REMCODE",REMCODE)) Q:REMCODE="" D RMD
Q
;
RMD ;EP
NEW IEN
I $G(FGLOB)'="" D Q
. S IEN=""
. F S IEN=$O(@FGLOB@(IEN)) Q:'IEN D RMF(IEN)
;
I $G(FGLOB)="" D
. S IEN=0
. F S IEN=$O(^BQIPAT(IEN)) Q:'IEN D RMF(IEN)
Q
;
RMF(DFN) ;EP - Find reminder
NEW RIEN,RDATA
S RIEN=$O(^BQIPAT(DFN,40,"B",REMCODE,""))
I RIEN="" Q
S RDATA=$G(^BQIPAT(DFN,40,RIEN,0)) I RDATA="" Q
I $P(RDATA,U,3)=""!($P(RDATA,U,3)="N/A")&($P(RDATA,U,4)="") Q
;
I FUT'=0 D Q
. I $P(RDATA,U,3)="DUE NOW" Q
. I $P(RDATA,U,3)="RESOLVED" Q
. I $P(RDATA,U,3)="DONE" Q
. I $P(RDATA,U,4)'="" D
.. I $G(RMFROM)'="" D
... I $P(RDATA,U,4)<RMFROM!($P(RDATA,U,4)>RMTHRU) Q
... S @TGLOB@(DFN)="",@CRIT@("REM",DFN,REMCODE)=""
.. I $G(RMFROM)="",$P(RDATA,U,4)>DT S @TGLOB@(DFN)="",@CRIT@("REM",DFN,REMCODE)="" Q
;
I OVD'=0 D Q
. I $P(RDATA,U,3)="RESOLVED" Q
. I $P(RDATA,U,3)="DONE" Q
. I $P(RDATA,U,4)>DT Q
. S @TGLOB@(DFN)="",@CRIT@("REM",DFN,REMCODE)=""
Q
;
POVS(FGLOB,TGLOB,POVS,POVSB,FDT,TDT,CNOT,MPARMS) ;EP - POV SNOMED search
NEW PVPT,PSUB,TREF,NGLOB,LCT,CT,IEN,PVS
S NGLOB=$NA(^TMP("BQIDCPOVS",$J)) K @NGLOB
I $G(TGLOB)="" Q
I $G(POVS)'="" D PVS
I $G(POVSB)'="" D
. S TREF=$NA(^TMP("BQISNLST",$J))
. K @TREF
. S OK=$$SUBLST^BSTSAPI(TREF,POVSB_"^36^1")
. S PVS="" F S PVS=$O(@TREF@(PVS)) Q:PVS="" S POVS=$P(@TREF@(PVS),"^",1),MPARMS("POVS",POVS)=""
I PVOP="!" D
. I $D(MPARMS("POVS")) S POVS="" F S POVS=$O(MPARMS("POVS",POVS)) Q:POVS="" D PVS
I PVOP="&" D
. K PVPT
. S POVS="",CT=0 F S POVS=$O(MPARMS("POVS",POVS)) Q:POVS="" D PVS S CT=CT+1
. S IEN=""
. F S IEN=$O(PVPT(IEN)) Q:IEN="" D
.. S LCT=0,LB=""
.. F S LB=$O(PVPT(IEN,LB)) Q:LB="" S LCT=LCT+1
.. I LCT'=CT K PVPT(IEN),@CRIT@("POV",IEN) Q
.. I LCT=CT,'CNOT S @TGLOB@(IEN)="" Q
.. I LCT=CT,CNOT S @NGLOB@(IEN)="" K @CRIT@("POV",IEN)
;
I CNOT,$G(FGLOB)'="" D
. S IEN="" F S IEN=$O(@FGLOB@(IEN)) Q:IEN="" D
.. I '$D(@NGLOB@(IEN)) S @TGLOB@(IEN)=""
I CNOT,$G(FGLOB)="" D
. S IEN=0 F S IEN=$O(^AUPNPAT(IEN)) Q:'IEN I '$D(@NGLOB@(IEN)) S @TGLOB@(IEN)=""
K @NGLOB
Q
;
PVS ;
NEW DFN,IEN
S TDT=$S(TDT'="":TDT,1:DT)
I $G(FGLOB)'="" D Q
. NEW IEN
. S IEN=""
. F S IEN=$O(@FGLOB@(IEN)) Q:'IEN D
.. I FDT="" D
... S BDT=""
... F S BDT=$O(^AUPNVPOV("ASNC",IEN,POVS,BDT)) Q:BDT="" D PVSDT
.. I FDT'="" D
... S BGT=9999999-FDT,ENT=9999999-TDT,BDT=ENT-1
... F S BDT=$O(^AUPNVPOV("ASNC",IEN,POVS,BDT)) Q:BDT=""!(BDT>BGT) D PVSDT
;
S IEN=""
F S IEN=$O(^AUPNVPOV("ASCI",POVS,IEN)) Q:IEN="" D
. I $G(^AUPNVPOV(IEN,0))="" Q
. S DFN=$P($G(^AUPNVPOV(IEN,0)),U,2),VIS=$P(^AUPNVPOV(IEN,0),U,3) I VIS="" Q
. I $G(^AUPNVSIT(VIS,0))="" Q
. Q:"DXCT"[$P(^AUPNVSIT(VIS,0),U,7)
. S VSDTM=$P(^AUPNVSIT(VIS,0),U,1)\1
. I FDT'="",VSDTM<FDT!(VSDTM>TDT) Q
. I DFN'="",PVOP="!",'CNOT S @TGLOB@(DFN)="",@CRIT@("POV",DFN,IEN)="" Q
. I DFN'="",PVOP="!",CNOT S @NGLOB@(DFN)="" Q
. I DFN'="",PVOP="&" S PVPT(DFN,POV)=IEN,@CRIT@("POV",DFN,IEN)=""
;
Q
;
PVSDT ; EP
S LIEN=""
F S LIEN=$O(^AUPNVPOV("ASNC",IEN,POVS,BDT,LIEN)) Q:LIEN="" D
. I $P($G(^AUPNVPOV(LIEN,11)),U,1)'=POVS Q
. S VIS=$P($G(^AUPNVPOV(LIEN,0)),U,3) I VIS="" Q
. I $G(^AUPNVSIT(VIS,0))="" Q
. Q:"DXCT"[$P(^AUPNVSIT(VIS,0),U,7)
. I PVOP="!",'CNOT S @TGLOB@(IEN)=LIEN,@CRIT@("POV",IEN,LIEN)="" Q
. I PVOP="!",CNOT S @NGLOB@(IEN)="" Q
. I PVOP="&" S PVPT(IEN,POV)=LIEN,@CRIT@("POV",DFN,IEN)=""
Q
;
POV(FGLOB,TGLOB,POV,POVTX,FDT,TDT,CNOT,MPARMS) ;EP - POV search
NEW PVPT,PTAX,TREF,NGLOB,LCT,CT,IEN
S NGLOB=$NA(^TMP("BQIDCPOV",$J)) K @NGLOB
I $G(TGLOB)="" Q
I $G(POV)'="" D PV
I $G(POVTX)'="" D
. S TREF=$NA(MPARMS("POV"))
. K @TREF
. S PTAX=$P(@("^"_$P(POVTX,";",2)_$P(POVTX,";",1)_",0)"),"^",1)
. D BLD^BQITUTL(PTAX,TREF)
I PVOP="!" D
. I $D(MPARMS("POV")) S POV="" F S POV=$O(MPARMS("POV",POV)) Q:POV="" D PV
I PVOP="&" D
. K PVPT
. S POV="",CT=0 F S POV=$O(MPARMS("POV",POV)) Q:POV="" D PV S CT=CT+1
. S IEN=""
. F S IEN=$O(PVPT(IEN)) Q:IEN="" D
.. S LCT=0,LB=""
.. F S LB=$O(PVPT(IEN,LB)) Q:LB="" S LCT=LCT+1
.. I LCT'=CT K PVPT(IEN),@CRIT@("POV",IEN) Q
.. I LCT=CT,'CNOT S @TGLOB@(IEN)="" Q
.. I LCT=CT,CNOT S @NGLOB@(IEN)="" K @CRIT@("POV",IEN)
;
I CNOT,$G(FGLOB)'="" D
. S IEN="" F S IEN=$O(@FGLOB@(IEN)) Q:IEN="" D
.. I '$D(@NGLOB@(IEN)) S @TGLOB@(IEN)=""
I CNOT,$G(FGLOB)="" D
. S IEN=0 F S IEN=$O(^AUPNPAT(IEN)) Q:'IEN I '$D(@NGLOB@(IEN)) S @TGLOB@(IEN)=""
K @NGLOB
Q
;
PV ;EP
NEW DFN,IEN
S TDT=$S(TDT'="":TDT,1:DT)
I $G(FGLOB)'="" D Q
. NEW IEN
. S IEN=""
. F S IEN=$O(@FGLOB@(IEN)) Q:'IEN D
.. I FDT="" D
... S BDT=""
... F S BDT=$O(^AUPNVPOV("AA",IEN,BDT)) Q:BDT="" D PVDT
.. I FDT'="" D
... S BGT=9999999-FDT,ENT=9999999-TDT,BDT=ENT-1
... F S BDT=$O(^AUPNVPOV("AA",IEN,BDT)) Q:BDT=""!(BDT>BGT) D PVDT
;
S IEN=""
F S IEN=$O(^AUPNVPOV("B",POV,IEN)) Q:IEN="" D
. I $G(^AUPNVPOV(IEN,0))="" Q
. S DFN=$P($G(^AUPNVPOV(IEN,0)),U,2),VIS=$P(^AUPNVPOV(IEN,0),U,3) I VIS="" Q
. I $G(^AUPNVSIT(VIS,0))="" Q
. Q:"DXCT"[$P(^AUPNVSIT(VIS,0),U,7)
. S VSDTM=$P(^AUPNVSIT(VIS,0),U,1)\1
. I FDT'="",VSDTM<FDT!(VSDTM>TDT) Q
. I DFN'="",PVOP="!",'CNOT S @TGLOB@(DFN)="",@CRIT@("POV",DFN,IEN)="" Q
. I DFN'="",PVOP="!",CNOT S @NGLOB@(DFN)="" Q
. I DFN'="",PVOP="&" S PVPT(DFN,POV)=IEN,@CRIT@("POV",DFN,IEN)=""
;
Q
;
PVDT ;EP
S LIEN=""
F S LIEN=$O(^AUPNVPOV("AA",IEN,BDT,LIEN)) Q:LIEN="" D
. I $P($G(^AUPNVPOV(LIEN,0)),U,1)'=POV Q
. S VIS=$P($G(^AUPNVPOV(LIEN,0)),U,3) I VIS="" Q
. I $G(^AUPNVSIT(VIS,0))="" Q
. Q:"DXCT"[$P(^AUPNVSIT(VIS,0),U,7)
. I PVOP="!",'CNOT S @TGLOB@(IEN)=LIEN,@CRIT@("POV",IEN,LIEN)="" Q
. I PVOP="!",CNOT S @NGLOB@(IEN)="" Q
. I PVOP="&" S PVPT(IEN,POV)=LIEN,@CRIT@("POV",DFN,IEN)=""
Q
BQIDCAH6 ;GDIT/HS/ALA-Ad Hoc Logic ; 26 Apr 2013 11:00 AM
+1 ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
+2 ;
ALGY(FGLOB,TGLOB,BEN,MPARMS) ;EP - Allergy search
+1 NEW ALGPT,AIEN,ACT,AL,CT,LIEN
+2 IF $GET(TGLOB)=""
QUIT
+3 IF $GET(ALNAS)'=""
DO ANAS
QUIT
+4 IF $GET(ALNKN)'=""
DO NKNN
QUIT
+5 IF $GET(ALLERGY)]""
DO ALGY1
+6 IF $DATA(MPARMS("ALLERGY"))
Begin DoDot:1
+7 IF ALLOP="!"
Begin DoDot:2
+8 SET ALLERGY=""
FOR
SET ALLERGY=$ORDER(MPARMS("ALLERGY",ALLERGY))
IF ALLERGY=""
QUIT
DO ALGY1
End DoDot:2
QUIT
+9 IF ALLOP="&"
Begin DoDot:2
+10 SET ALLERGY=""
SET CT=0
+11 FOR
SET ALLERGY=$ORDER(MPARMS("ALLERGY",ALLERGY))
IF ALLERGY=""
QUIT
SET CT=CT+1
+12 FOR
SET ALLERGY=$ORDER(MPARMS("ALLERGY",ALLERGY))
IF ALLERGY=""
QUIT
DO ALGY1
+13 IF ALLOP="&"
Begin DoDot:3
+14 SET IEN=""
+15 FOR
SET IEN=$ORDER(ALGPT(IEN))
IF IEN=""
QUIT
Begin DoDot:4
+16 SET ACT=0
SET AL=""
+17 FOR
SET AL=$ORDER(ALGPT(IEN,AL))
IF AL=""
QUIT
SET ACT=ACT+1
+18 IF ACT'=CT
KILL @CRIT@("ALGY",IEN)
QUIT
+19 SET AL=""
FOR
SET AL=$ORDER(ALGPT(IEN,AL))
IF AL=""
QUIT
SET @TGLOB@(IEN)=""
SET LIEN=ALGPT(IEN,AL)
SET @CRIT@("ALGY",IEN,LIEN)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+20 KILL ALGPT
+21 QUIT
+22 ;
ALGY1 ;EP
+1 NEW IEN,ALGTX,AN,DFN,TALLG
+2 IF $GET(FGLOB)'=""
Begin DoDot:1
+3 SET IEN=""
+4 FOR
SET IEN=$ORDER(@FGLOB@(IEN))
IF 'IEN
QUIT
Begin DoDot:2
+5 SET AN=""
+6 FOR
SET AN=$ORDER(^GMR(120.8,"B",IEN,AN))
IF AN=""
QUIT
Begin DoDot:3
+7 ; If ENTERED IN ERROR, ignore
+8 IF $$GET1^DIQ(120.8,AN_",",22,"I")=1
QUIT
+9 SET ALGTX=$$GET1^DIQ(120.8,AN_",",.02,"E")
+10 IF $EXTRACT(ALGTX,$LENGTH(ALGTX),$LENGTH(ALGTX))=" "
SET ALGTX=$$STRIP^BQIUL1(ALGTX," ")
+11 IF ALGTX=ALLERGY
Begin DoDot:4
+12 IF ALLOP="!"
SET @TGLOB@(IEN)=""
SET @CRIT@("ALGY",IEN,AN)=AN
QUIT
+13 SET ALGPT(IEN,AN)=AN
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+14 ;
+15 IF $LENGTH(ALLERGY)'>30
Begin DoDot:1
+16 NEW ALGTX,TXT
+17 SET IEN=""
+18 FOR
SET IEN=$ORDER(^GMR(120.8,"C",ALLERGY,IEN))
IF IEN=""
QUIT
DO ALCK
+19 SET ALGTX=$ORDER(^GMR(120.8,"C",ALLERGY))
SET TXT=ALLERGY_" "
+20 IF ALGTX=TXT
Begin DoDot:2
+21 FOR
SET IEN=$ORDER(^GMR(120.8,"C",ALGTX,IEN))
IF IEN=""
QUIT
DO ALCK
End DoDot:2
End DoDot:1
+22 ;
+23 IF $LENGTH(ALLERGY)>30
Begin DoDot:1
+24 SET TALLG=ALLERGY
+25 FOR
SET TALLG=$ORDER(^GMR(120.8,"C",TALLG))
IF TALLG=""!($EXTRACT(ALLERGY,1,30)'=$EXTRACT(TALLG,1,30))
QUIT
Begin DoDot:2
+26 SET IEN=""
+27 FOR
SET IEN=$ORDER(^GMR(120.8,"C",TALLG,IEN))
IF IEN=""
QUIT
DO ALCK
End DoDot:2
End DoDot:1
+28 QUIT
+29 ;
ALCK ;EP
+1 IF $$GET1^DIQ(120.8,IEN_",",22,"I")=1
QUIT
+2 SET DFN=$$GET1^DIQ(120.8,IEN_",",.01,"I")
+3 IF ALLOP="!"
SET @TGLOB@(DFN)=""
SET @CRIT@("ALGY",DFN,IEN)=IEN
QUIT
+4 SET ALGPT(DFN,IEN)=IEN
+5 QUIT
+6 ;
ANAS ;EP - No allergy assessment
+1 NEW ADATA,IEN
+2 IF $GET(FGLOB)'=""
Begin DoDot:1
+3 SET IEN=""
+4 FOR
SET IEN=$ORDER(@FGLOB@(IEN))
IF 'IEN
QUIT
Begin DoDot:2
+5 DO DETAIL^BEHOCACV(.ADATA,IEN)
+6 IF $GET(@ADATA@(1))="No allergy assessment."
SET @TGLOB@(IEN)=""
End DoDot:2
End DoDot:1
QUIT
+7 IF $GET(FGLOB)=""
Begin DoDot:1
+8 SET IEN=0
+9 FOR
SET IEN=$ORDER(^AUPNPAT(IEN))
IF 'IEN
QUIT
Begin DoDot:2
+10 IF $DATA(^AUPNPAT(IEN,-9))
QUIT
+11 DO DETAIL^BEHOCACV(.ADATA,IEN)
+12 IF $GET(@ADATA@(1))="No allergy assessment."
SET @TGLOB@(IEN)=""
End DoDot:2
End DoDot:1
QUIT
+13 QUIT
+14 ;
NKNN ;EP - No known allergy
+1 NEW ADATA,IEN
+2 IF $GET(FGLOB)'=""
Begin DoDot:1
+3 SET IEN=""
+4 FOR
SET IEN=$ORDER(@FGLOB@(IEN))
IF 'IEN
QUIT
Begin DoDot:2
+5 DO DETAIL^BEHOCACV(.ADATA,IEN)
+6 IF $GET(@ADATA@(1))="No known allergies."
SET @TGLOB@(IEN)=""
End DoDot:2
End DoDot:1
QUIT
+7 IF $GET(FGLOB)=""
Begin DoDot:1
+8 SET IEN=0
+9 FOR
SET IEN=$ORDER(^AUPNPAT(IEN))
IF 'IEN
QUIT
Begin DoDot:2
+10 IF $DATA(^AUPNPAT(IEN,-9))
QUIT
+11 DO DETAIL^BEHOCACV(.ADATA,IEN)
+12 IF $GET(@ADATA@(1))="No known allergies."
SET @TGLOB@(IEN)=""
End DoDot:2
End DoDot:1
QUIT
+13 QUIT
+14 ;
REM(FGLOB,TGLOB,REMCODE,RMFROM,RMTHRU,OVD,FUT,MPARMS) ;EP
+1 IF $GET(TGLOB)=""
QUIT
+2 IF $GET(REMCODE)'=""
DO RMD
+3 IF $DATA(MPARMS("REMCODE"))
Begin DoDot:1
+4 SET REMCODE=""
+5 FOR
SET REMCODE=$ORDER(MPARMS("REMCODE",REMCODE))
IF REMCODE=""
QUIT
DO RMD
End DoDot:1
+6 QUIT
+7 ;
RMD ;EP
+1 NEW IEN
+2 IF $GET(FGLOB)'=""
Begin DoDot:1
+3 SET IEN=""
+4 FOR
SET IEN=$ORDER(@FGLOB@(IEN))
IF 'IEN
QUIT
DO RMF(IEN)
End DoDot:1
QUIT
+5 ;
+6 IF $GET(FGLOB)=""
Begin DoDot:1
+7 SET IEN=0
+8 FOR
SET IEN=$ORDER(^BQIPAT(IEN))
IF 'IEN
QUIT
DO RMF(IEN)
End DoDot:1
+9 QUIT
+10 ;
RMF(DFN) ;EP - Find reminder
+1 NEW RIEN,RDATA
+2 SET RIEN=$ORDER(^BQIPAT(DFN,40,"B",REMCODE,""))
+3 IF RIEN=""
QUIT
+4 SET RDATA=$GET(^BQIPAT(DFN,40,RIEN,0))
IF RDATA=""
QUIT
+5 IF $PIECE(RDATA,U,3)=""!($PIECE(RDATA,U,3)="N/A")&($PIECE(RDATA,U,4)="")
QUIT
+6 ;
+7 IF FUT'=0
Begin DoDot:1
+8 IF $PIECE(RDATA,U,3)="DUE NOW"
QUIT
+9 IF $PIECE(RDATA,U,3)="RESOLVED"
QUIT
+10 IF $PIECE(RDATA,U,3)="DONE"
QUIT
+11 IF $PIECE(RDATA,U,4)'=""
Begin DoDot:2
+12 IF $GET(RMFROM)'=""
Begin DoDot:3
+13 IF $PIECE(RDATA,U,4)<RMFROM!($PIECE(RDATA,U,4)>RMTHRU)
QUIT
+14 SET @TGLOB@(DFN)=""
SET @CRIT@("REM",DFN,REMCODE)=""
End DoDot:3
+15 IF $GET(RMFROM)=""
IF $PIECE(RDATA,U,4)>DT
SET @TGLOB@(DFN)=""
SET @CRIT@("REM",DFN,REMCODE)=""
QUIT
End DoDot:2
End DoDot:1
QUIT
+16 ;
+17 IF OVD'=0
Begin DoDot:1
+18 IF $PIECE(RDATA,U,3)="RESOLVED"
QUIT
+19 IF $PIECE(RDATA,U,3)="DONE"
QUIT
+20 IF $PIECE(RDATA,U,4)>DT
QUIT
+21 SET @TGLOB@(DFN)=""
SET @CRIT@("REM",DFN,REMCODE)=""
End DoDot:1
QUIT
+22 QUIT
+23 ;
POVS(FGLOB,TGLOB,POVS,POVSB,FDT,TDT,CNOT,MPARMS) ;EP - POV SNOMED search
+1 NEW PVPT,PSUB,TREF,NGLOB,LCT,CT,IEN,PVS
+2 SET NGLOB=$NAME(^TMP("BQIDCPOVS",$JOB))
KILL @NGLOB
+3 IF $GET(TGLOB)=""
QUIT
+4 IF $GET(POVS)'=""
DO PVS
+5 IF $GET(POVSB)'=""
Begin DoDot:1
+6 SET TREF=$NAME(^TMP("BQISNLST",$JOB))
+7 KILL @TREF
+8 SET OK=$$SUBLST^BSTSAPI(TREF,POVSB_"^36^1")
+9 SET PVS=""
FOR
SET PVS=$ORDER(@TREF@(PVS))
IF PVS=""
QUIT
SET POVS=$PIECE(@TREF@(PVS),"^",1)
SET MPARMS("POVS",POVS)=""
End DoDot:1
+10 IF PVOP="!"
Begin DoDot:1
+11 IF $DATA(MPARMS("POVS"))
SET POVS=""
FOR
SET POVS=$ORDER(MPARMS("POVS",POVS))
IF POVS=""
QUIT
DO PVS
End DoDot:1
+12 IF PVOP="&"
Begin DoDot:1
+13 KILL PVPT
+14 SET POVS=""
SET CT=0
FOR
SET POVS=$ORDER(MPARMS("POVS",POVS))
IF POVS=""
QUIT
DO PVS
SET CT=CT+1
+15 SET IEN=""
+16 FOR
SET IEN=$ORDER(PVPT(IEN))
IF IEN=""
QUIT
Begin DoDot:2
+17 SET LCT=0
SET LB=""
+18 FOR
SET LB=$ORDER(PVPT(IEN,LB))
IF LB=""
QUIT
SET LCT=LCT+1
+19 IF LCT'=CT
KILL PVPT(IEN),@CRIT@("POV",IEN)
QUIT
+20 IF LCT=CT
IF 'CNOT
SET @TGLOB@(IEN)=""
QUIT
+21 IF LCT=CT
IF CNOT
SET @NGLOB@(IEN)=""
KILL @CRIT@("POV",IEN)
End DoDot:2
End DoDot:1
+22 ;
+23 IF CNOT
IF $GET(FGLOB)'=""
Begin DoDot:1
+24 SET IEN=""
FOR
SET IEN=$ORDER(@FGLOB@(IEN))
IF IEN=""
QUIT
Begin DoDot:2
+25 IF '$DATA(@NGLOB@(IEN))
SET @TGLOB@(IEN)=""
End DoDot:2
End DoDot:1
+26 IF CNOT
IF $GET(FGLOB)=""
Begin DoDot:1
+27 SET IEN=0
FOR
SET IEN=$ORDER(^AUPNPAT(IEN))
IF 'IEN
QUIT
IF '$DATA(@NGLOB@(IEN))
SET @TGLOB@(IEN)=""
End DoDot:1
+28 KILL @NGLOB
+29 QUIT
+30 ;
PVS ;
+1 NEW DFN,IEN
+2 SET TDT=$SELECT(TDT'="":TDT,1:DT)
+3 IF $GET(FGLOB)'=""
Begin DoDot:1
+4 NEW IEN
+5 SET IEN=""
+6 FOR
SET IEN=$ORDER(@FGLOB@(IEN))
IF 'IEN
QUIT
Begin DoDot:2
+7 IF FDT=""
Begin DoDot:3
+8 SET BDT=""
+9 FOR
SET BDT=$ORDER(^AUPNVPOV("ASNC",IEN,POVS,BDT))
IF BDT=""
QUIT
DO PVSDT
End DoDot:3
+10 IF FDT'=""
Begin DoDot:3
+11 SET BGT=9999999-FDT
SET ENT=9999999-TDT
SET BDT=ENT-1
+12 FOR
SET BDT=$ORDER(^AUPNVPOV("ASNC",IEN,POVS,BDT))
IF BDT=""!(BDT>BGT)
QUIT
DO PVSDT
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+13 ;
+14 SET IEN=""
+15 FOR
SET IEN=$ORDER(^AUPNVPOV("ASCI",POVS,IEN))
IF IEN=""
QUIT
Begin DoDot:1
+16 IF $GET(^AUPNVPOV(IEN,0))=""
QUIT
+17 SET DFN=$PIECE($GET(^AUPNVPOV(IEN,0)),U,2)
SET VIS=$PIECE(^AUPNVPOV(IEN,0),U,3)
IF VIS=""
QUIT
+18 IF $GET(^AUPNVSIT(VIS,0))=""
QUIT
+19 IF "DXCT"[$PIECE(^AUPNVSIT(VIS,0),U,7)
QUIT
+20 SET VSDTM=$PIECE(^AUPNVSIT(VIS,0),U,1)\1
+21 IF FDT'=""
IF VSDTM<FDT!(VSDTM>TDT)
QUIT
+22 IF DFN'=""
IF PVOP="!"
IF 'CNOT
SET @TGLOB@(DFN)=""
SET @CRIT@("POV",DFN,IEN)=""
QUIT
+23 IF DFN'=""
IF PVOP="!"
IF CNOT
SET @NGLOB@(DFN)=""
QUIT
+24 IF DFN'=""
IF PVOP="&"
SET PVPT(DFN,POV)=IEN
SET @CRIT@("POV",DFN,IEN)=""
End DoDot:1
+25 ;
+26 QUIT
+27 ;
PVSDT ; EP
+1 SET LIEN=""
+2 FOR
SET LIEN=$ORDER(^AUPNVPOV("ASNC",IEN,POVS,BDT,LIEN))
IF LIEN=""
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^AUPNVPOV(LIEN,11)),U,1)'=POVS
QUIT
+4 SET VIS=$PIECE($GET(^AUPNVPOV(LIEN,0)),U,3)
IF VIS=""
QUIT
+5 IF $GET(^AUPNVSIT(VIS,0))=""
QUIT
+6 IF "DXCT"[$PIECE(^AUPNVSIT(VIS,0),U,7)
QUIT
+7 IF PVOP="!"
IF 'CNOT
SET @TGLOB@(IEN)=LIEN
SET @CRIT@("POV",IEN,LIEN)=""
QUIT
+8 IF PVOP="!"
IF CNOT
SET @NGLOB@(IEN)=""
QUIT
+9 IF PVOP="&"
SET PVPT(IEN,POV)=LIEN
SET @CRIT@("POV",DFN,IEN)=""
End DoDot:1
+10 QUIT
+11 ;
POV(FGLOB,TGLOB,POV,POVTX,FDT,TDT,CNOT,MPARMS) ;EP - POV search
+1 NEW PVPT,PTAX,TREF,NGLOB,LCT,CT,IEN
+2 SET NGLOB=$NAME(^TMP("BQIDCPOV",$JOB))
KILL @NGLOB
+3 IF $GET(TGLOB)=""
QUIT
+4 IF $GET(POV)'=""
DO PV
+5 IF $GET(POVTX)'=""
Begin DoDot:1
+6 SET TREF=$NAME(MPARMS("POV"))
+7 KILL @TREF
+8 SET PTAX=$PIECE(@("^"_$PIECE(POVTX,";",2)_$PIECE(POVTX,";",1)_",0)"),"^",1)
+9 DO BLD^BQITUTL(PTAX,TREF)
End DoDot:1
+10 IF PVOP="!"
Begin DoDot:1
+11 IF $DATA(MPARMS("POV"))
SET POV=""
FOR
SET POV=$ORDER(MPARMS("POV",POV))
IF POV=""
QUIT
DO PV
End DoDot:1
+12 IF PVOP="&"
Begin DoDot:1
+13 KILL PVPT
+14 SET POV=""
SET CT=0
FOR
SET POV=$ORDER(MPARMS("POV",POV))
IF POV=""
QUIT
DO PV
SET CT=CT+1
+15 SET IEN=""
+16 FOR
SET IEN=$ORDER(PVPT(IEN))
IF IEN=""
QUIT
Begin DoDot:2
+17 SET LCT=0
SET LB=""
+18 FOR
SET LB=$ORDER(PVPT(IEN,LB))
IF LB=""
QUIT
SET LCT=LCT+1
+19 IF LCT'=CT
KILL PVPT(IEN),@CRIT@("POV",IEN)
QUIT
+20 IF LCT=CT
IF 'CNOT
SET @TGLOB@(IEN)=""
QUIT
+21 IF LCT=CT
IF CNOT
SET @NGLOB@(IEN)=""
KILL @CRIT@("POV",IEN)
End DoDot:2
End DoDot:1
+22 ;
+23 IF CNOT
IF $GET(FGLOB)'=""
Begin DoDot:1
+24 SET IEN=""
FOR
SET IEN=$ORDER(@FGLOB@(IEN))
IF IEN=""
QUIT
Begin DoDot:2
+25 IF '$DATA(@NGLOB@(IEN))
SET @TGLOB@(IEN)=""
End DoDot:2
End DoDot:1
+26 IF CNOT
IF $GET(FGLOB)=""
Begin DoDot:1
+27 SET IEN=0
FOR
SET IEN=$ORDER(^AUPNPAT(IEN))
IF 'IEN
QUIT
IF '$DATA(@NGLOB@(IEN))
SET @TGLOB@(IEN)=""
End DoDot:1
+28 KILL @NGLOB
+29 QUIT
+30 ;
PV ;EP
+1 NEW DFN,IEN
+2 SET TDT=$SELECT(TDT'="":TDT,1:DT)
+3 IF $GET(FGLOB)'=""
Begin DoDot:1
+4 NEW IEN
+5 SET IEN=""
+6 FOR
SET IEN=$ORDER(@FGLOB@(IEN))
IF 'IEN
QUIT
Begin DoDot:2
+7 IF FDT=""
Begin DoDot:3
+8 SET BDT=""
+9 FOR
SET BDT=$ORDER(^AUPNVPOV("AA",IEN,BDT))
IF BDT=""
QUIT
DO PVDT
End DoDot:3
+10 IF FDT'=""
Begin DoDot:3
+11 SET BGT=9999999-FDT
SET ENT=9999999-TDT
SET BDT=ENT-1
+12 FOR
SET BDT=$ORDER(^AUPNVPOV("AA",IEN,BDT))
IF BDT=""!(BDT>BGT)
QUIT
DO PVDT
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+13 ;
+14 SET IEN=""
+15 FOR
SET IEN=$ORDER(^AUPNVPOV("B",POV,IEN))
IF IEN=""
QUIT
Begin DoDot:1
+16 IF $GET(^AUPNVPOV(IEN,0))=""
QUIT
+17 SET DFN=$PIECE($GET(^AUPNVPOV(IEN,0)),U,2)
SET VIS=$PIECE(^AUPNVPOV(IEN,0),U,3)
IF VIS=""
QUIT
+18 IF $GET(^AUPNVSIT(VIS,0))=""
QUIT
+19 IF "DXCT"[$PIECE(^AUPNVSIT(VIS,0),U,7)
QUIT
+20 SET VSDTM=$PIECE(^AUPNVSIT(VIS,0),U,1)\1
+21 IF FDT'=""
IF VSDTM<FDT!(VSDTM>TDT)
QUIT
+22 IF DFN'=""
IF PVOP="!"
IF 'CNOT
SET @TGLOB@(DFN)=""
SET @CRIT@("POV",DFN,IEN)=""
QUIT
+23 IF DFN'=""
IF PVOP="!"
IF CNOT
SET @NGLOB@(DFN)=""
QUIT
+24 IF DFN'=""
IF PVOP="&"
SET PVPT(DFN,POV)=IEN
SET @CRIT@("POV",DFN,IEN)=""
End DoDot:1
+25 ;
+26 QUIT
+27 ;
PVDT ;EP
+1 SET LIEN=""
+2 FOR
SET LIEN=$ORDER(^AUPNVPOV("AA",IEN,BDT,LIEN))
IF LIEN=""
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^AUPNVPOV(LIEN,0)),U,1)'=POV
QUIT
+4 SET VIS=$PIECE($GET(^AUPNVPOV(LIEN,0)),U,3)
IF VIS=""
QUIT
+5 IF $GET(^AUPNVSIT(VIS,0))=""
QUIT
+6 IF "DXCT"[$PIECE(^AUPNVSIT(VIS,0),U,7)
QUIT
+7 IF PVOP="!"
IF 'CNOT
SET @TGLOB@(IEN)=LIEN
SET @CRIT@("POV",IEN,LIEN)=""
QUIT
+8 IF PVOP="!"
IF CNOT
SET @NGLOB@(IEN)=""
QUIT
+9 IF PVOP="&"
SET PVPT(IEN,POV)=LIEN
SET @CRIT@("POV",DFN,IEN)=""
End DoDot:1
+10 QUIT
