BQITRALG ;APTIV/HC/ALA-Treatment Prompts Allergy ; 29 Feb 2008 4:18 PM
;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
;
STAT(BQDFN,BDATE,EDATE) ;EP - Statin
NEW BQGPYR,BQGPIN,DFN
S DFN=BQDFN
S BQGPYR=$O(^BGPCTRL("B",""),-1),BQGPIN=$O(^BGPCTRL("B",BQGPYR,0))
I BQGPYR<2008 D
. S PRGM="S BQX=$$STATALG^BGP7D722(BQDFN,BDATE,EDATE,BDATE,EDATE)"
I BQGPYR>2007 D
. S QFL=0
. I $$VFIELD^DILFD(90241.01,.18) D Q:QFL
.. S BQGPRG=$$GET1^DIQ(90241.01,BQGPIN_",",.18,"E")
.. I $T(@("STATIN^"_BQGPRG))="" Q
.. S PRGM="S BQX=$$STATIN^"_BQGPRG_"(BQDFN,BDATE,EDATE)"
.. ;S PRGM="S BQX=""$$STATIN^""_BQGPRG_""(BQDFN,BDATE,EDATE)"""
.. S QFL=1
. S PRGM="S BQX=$$STATALG^BGP8D722(BQDFN,BDATE,EDATE,BDATE,EDATE)"
;
X PRGM
Q BQX
;
BETA(BQDFN,BDATE,EDATE) ;EP - Beta Blocker
NEW BQGPYR,BQGPIN,DFN
S DFN=BQDFN
S BQGPYR=$O(^BGPCTRL("B",""),-1),BQGPIN=$O(^BGPCTRL("B",BQGPYR,0))
I BQGPYR<2008 D
. S PRGM="S BQX=$$BETAALG1^BGP7D72(BQDFN,EDATE)"
I BQGPYR>2007 D
. S QFL=0
. I $$VFIELD^DILFD(90241.01,.18) D Q:QFL
.. S BQGPRG=$$GET1^DIQ(90241.01,BQGPIN_",",.18,"E")
.. I $T(@("BETA^"_BQGPRG))="" Q
.. S PRGM="S BQX=$$BETA^"_BQGPRG_"(BQDFN,EDATE)"
.. ;S PRGM="S BQX=""$$BETA^""_BQGPRG_""(BQDFN,BDATE,EDATE)"""
.. S QFL=1
. S PRGM="S BQX=$$BETAALG1^BGP8D72(BQDFN,EDATE)"
;
X PRGM
Q BQX
;
ASA(BQDFN,BDATE,EDATE) ;EP - Asa/Warfarin
NEW BQGPYR,BQGPIN,BQX,DFN
S DFN=BQDFN
S BDATE=$G(BDATE,""),EDATE=$G(EDATE,"")
S BQGPYR=$O(^BGPCTRL("B",""),-1),BQGPIN=$O(^BGPCTRL("B",BQGPYR,0))
I BQGPYR<2008 D
. S PRGM="S BQX=$$ASAALLEG^BGP7D721(BQDFN,EDATE)"
I BQGPYR>2007 D
. S QFL=0
. I $$VFIELD^DILFD(90241.01,.18) D Q:QFL
.. S BQGPRG=$$GET1^DIQ(90241.01,BQGPIN_",",.18,"E")
.. I $T(@("ASA^"_BQGPRG))="" Q
.. S PRGM="S BQX=$$ASA^"_BQGPRG_"(BQDFN,EDATE)"
.. ;S PRGM="S BQX=""$$ASA^""_BQGPRG_""(BQDFN,BDATE,EDATE)"""
.. S QFL=1
. S PRGM="S BQX=$$ASAALLEG^BGP8D721(BQDFN,EDATE)"
;
X PRGM
Q BQX
;
ACEI(BQDFN,BDATE,EDATE) ;EP - ACEI/ARB
NEW BQGPYR,BQGPIN,DFN
S DFN=BQDFN
S BQGPYR=$O(^BGPCTRL("B",""),-1),BQGPIN=$O(^BGPCTRL("B",BQGPYR,0))
I BQGPYR<2008 D
. S PRGM="S BQX=$$ACEALG^BGP7D732(BQDFN,BDATE,EDATE)"
I BQGPYR>2007 D
. S QFL=0
. I $$VFIELD^DILFD(90241.01,.18) D Q:QFL
.. S BQGPRG=$$GET1^DIQ(90241.01,BQGPIN_",",.18,"E")
.. I $T(@("ACEI^"_BQGPRG))="" Q
.. S PRGM="S BQX=$$ACEI^"_BQGPRG_"(BQDFN,EDATE)"
.. ;S PRGM="S BQX=""$$ACEI^""_BQGPRG_""(BQDFN,BDATE,EDATE)"""
.. S QFL=1
. S PRGM="S BQX=$$ACEALG^BGP8D732(BQDFN,BDATE,EDATE)"
;
X PRGM
Q BQX
;
ACE(BQDFN,BDATE,EDATE) ;EP - ACE
NEW BQGPYR,BQGPIN,DFN
S DFN=BQDFN
S BQGPYR=$O(^BGPCTRL("B",""),-1),BQGPIN=$O(^BGPCTRL("B",BQGPYR,0))
I BQGPYR<2008 D
. S PRGM="S BQX=$$ACEALG^BGP7D722(BQDFN,BDATE,EDATE)"
I BQGPYR>2007 D
. S QFL=0
. I $$VFIELD^DILFD(90241.01,.18) D Q:QFL
.. S BQGPRG=$$GET1^DIQ(90241.01,BQGPIN_",",.18,"E")
.. I $T(@("ACE^"_BQGPRG))="" Q
.. S PRGM="S BQX=$$ACE^"_BQGPRG_"(BQDFN,BDATE,EDATE)"
.. ;S PRGM="S BQX=""$$ACE^""_BQGPRG_""(BQDFN,BDATE,EDATE)"""
.. S QFL=1
. S PRGM="S BQX=$$ACEALG^BGP8D722(BQDFN,BDATE,EDATE)"
;
X PRGM
Q BQX
BQITRALG ;APTIV/HC/ALA-Treatment Prompts Allergy ; 29 Feb 2008 4:18 PM
+1 ;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
+2 ;
STAT(BQDFN,BDATE,EDATE) ;EP - Statin
+1 NEW BQGPYR,BQGPIN,DFN
+2 SET DFN=BQDFN
+3 SET BQGPYR=$ORDER(^BGPCTRL("B",""),-1)
SET BQGPIN=$ORDER(^BGPCTRL("B",BQGPYR,0))
+4 IF BQGPYR<2008
Begin DoDot:1
+5 SET PRGM="S BQX=$$STATALG^BGP7D722(BQDFN,BDATE,EDATE,BDATE,EDATE)"
End DoDot:1
+6 IF BQGPYR>2007
Begin DoDot:1
+7 SET QFL=0
+8 IF $$VFIELD^DILFD(90241.01,.18)
Begin DoDot:2
+9 SET BQGPRG=$$GET1^DIQ(90241.01,BQGPIN_",",.18,"E")
+10 IF $TEXT(@("STATIN^"_BQGPRG))=""
QUIT
+11 SET PRGM="S BQX=$$STATIN^"_BQGPRG_"(BQDFN,BDATE,EDATE)"
+12 ;S PRGM="S BQX=""$$STATIN^""_BQGPRG_""(BQDFN,BDATE,EDATE)"""
+13 SET QFL=1
End DoDot:2
IF QFL
QUIT
+14 SET PRGM="S BQX=$$STATALG^BGP8D722(BQDFN,BDATE,EDATE,BDATE,EDATE)"
End DoDot:1
+15 ;
+16 XECUTE PRGM
+17 QUIT BQX
+18 ;
BETA(BQDFN,BDATE,EDATE) ;EP - Beta Blocker
+1 NEW BQGPYR,BQGPIN,DFN
+2 SET DFN=BQDFN
+3 SET BQGPYR=$ORDER(^BGPCTRL("B",""),-1)
SET BQGPIN=$ORDER(^BGPCTRL("B",BQGPYR,0))
+4 IF BQGPYR<2008
Begin DoDot:1
+5 SET PRGM="S BQX=$$BETAALG1^BGP7D72(BQDFN,EDATE)"
End DoDot:1
+6 IF BQGPYR>2007
Begin DoDot:1
+7 SET QFL=0
+8 IF $$VFIELD^DILFD(90241.01,.18)
Begin DoDot:2
+9 SET BQGPRG=$$GET1^DIQ(90241.01,BQGPIN_",",.18,"E")
+10 IF $TEXT(@("BETA^"_BQGPRG))=""
QUIT
+11 SET PRGM="S BQX=$$BETA^"_BQGPRG_"(BQDFN,EDATE)"
+12 ;S PRGM="S BQX=""$$BETA^""_BQGPRG_""(BQDFN,BDATE,EDATE)"""
+13 SET QFL=1
End DoDot:2
IF QFL
QUIT
+14 SET PRGM="S BQX=$$BETAALG1^BGP8D72(BQDFN,EDATE)"
End DoDot:1
+15 ;
+16 XECUTE PRGM
+17 QUIT BQX
+18 ;
ASA(BQDFN,BDATE,EDATE) ;EP - Asa/Warfarin
+1 NEW BQGPYR,BQGPIN,BQX,DFN
+2 SET DFN=BQDFN
+3 SET BDATE=$GET(BDATE,"")
SET EDATE=$GET(EDATE,"")
+4 SET BQGPYR=$ORDER(^BGPCTRL("B",""),-1)
SET BQGPIN=$ORDER(^BGPCTRL("B",BQGPYR,0))
+5 IF BQGPYR<2008
Begin DoDot:1
+6 SET PRGM="S BQX=$$ASAALLEG^BGP7D721(BQDFN,EDATE)"
End DoDot:1
+7 IF BQGPYR>2007
Begin DoDot:1
+8 SET QFL=0
+9 IF $$VFIELD^DILFD(90241.01,.18)
Begin DoDot:2
+10 SET BQGPRG=$$GET1^DIQ(90241.01,BQGPIN_",",.18,"E")
+11 IF $TEXT(@("ASA^"_BQGPRG))=""
QUIT
+12 SET PRGM="S BQX=$$ASA^"_BQGPRG_"(BQDFN,EDATE)"
+13 ;S PRGM="S BQX=""$$ASA^""_BQGPRG_""(BQDFN,BDATE,EDATE)"""
+14 SET QFL=1
End DoDot:2
IF QFL
QUIT
+15 SET PRGM="S BQX=$$ASAALLEG^BGP8D721(BQDFN,EDATE)"
End DoDot:1
+16 ;
+17 XECUTE PRGM
+18 QUIT BQX
+19 ;
ACEI(BQDFN,BDATE,EDATE) ;EP - ACEI/ARB
+1 NEW BQGPYR,BQGPIN,DFN
+2 SET DFN=BQDFN
+3 SET BQGPYR=$ORDER(^BGPCTRL("B",""),-1)
SET BQGPIN=$ORDER(^BGPCTRL("B",BQGPYR,0))
+4 IF BQGPYR<2008
Begin DoDot:1
+5 SET PRGM="S BQX=$$ACEALG^BGP7D732(BQDFN,BDATE,EDATE)"
End DoDot:1
+6 IF BQGPYR>2007
Begin DoDot:1
+7 SET QFL=0
+8 IF $$VFIELD^DILFD(90241.01,.18)
Begin DoDot:2
+9 SET BQGPRG=$$GET1^DIQ(90241.01,BQGPIN_",",.18,"E")
+10 IF $TEXT(@("ACEI^"_BQGPRG))=""
QUIT
+11 SET PRGM="S BQX=$$ACEI^"_BQGPRG_"(BQDFN,EDATE)"
+12 ;S PRGM="S BQX=""$$ACEI^""_BQGPRG_""(BQDFN,BDATE,EDATE)"""
+13 SET QFL=1
End DoDot:2
IF QFL
QUIT
+14 SET PRGM="S BQX=$$ACEALG^BGP8D732(BQDFN,BDATE,EDATE)"
End DoDot:1
+15 ;
+16 XECUTE PRGM
+17 QUIT BQX
+18 ;
ACE(BQDFN,BDATE,EDATE) ;EP - ACE
+1 NEW BQGPYR,BQGPIN,DFN
+2 SET DFN=BQDFN
+3 SET BQGPYR=$ORDER(^BGPCTRL("B",""),-1)
SET BQGPIN=$ORDER(^BGPCTRL("B",BQGPYR,0))
+4 IF BQGPYR<2008
Begin DoDot:1
+5 SET PRGM="S BQX=$$ACEALG^BGP7D722(BQDFN,BDATE,EDATE)"
End DoDot:1
+6 IF BQGPYR>2007
Begin DoDot:1
+7 SET QFL=0
+8 IF $$VFIELD^DILFD(90241.01,.18)
Begin DoDot:2
+9 SET BQGPRG=$$GET1^DIQ(90241.01,BQGPIN_",",.18,"E")
+10 IF $TEXT(@("ACE^"_BQGPRG))=""
QUIT
+11 SET PRGM="S BQX=$$ACE^"_BQGPRG_"(BQDFN,BDATE,EDATE)"
+12 ;S PRGM="S BQX=""$$ACE^""_BQGPRG_""(BQDFN,BDATE,EDATE)"""
+13 SET QFL=1
End DoDot:2
IF QFL
QUIT
+14 SET PRGM="S BQX=$$ACEALG^BGP8D722(BQDFN,BDATE,EDATE)"
End DoDot:1
+15 ;
+16 XECUTE PRGM
+17 QUIT BQX
