BKM100P1 ;PRXM/HC/ALA-BKM 1.00 Patch 1 ; 27 Sep 2006 10:29 AM
;;2.0;HIV MANAGEMENT SYSTEM;;May 29, 2009
;
CND ; Check candidate list and remove entries
NEW DFN,MED,DFLG,STAT,TAX
S DFN=0
F S DFN=$O(^BKM(90451.2,DFN)) Q:'DFN D
. S STAT=$P(^BKM(90451.2,DFN,0),U,3)
. I STAT="NOT"!(STAT="REM") Q
. S MED=0,DFLG=0
. F S MED=$O(^BKM(90451.2,DFN,3,MED)) Q:'MED D Q:DFLG
.. S TAX=$P(^BKM(90451.2,DFN,3,MED,0),U,3)
.. I TAX="BKMV EI MEDS"!(TAX="BKMV NNRTI MEDS")!(TAX="BKMV NRTI MEDS")!(TAX="BKMV PI MEDS") S DFLG=1 Q
. I DFLG D
.. NEW DA,DIK
.. S DA=DFN,DIK="^BKM(90451.2," D ^DIK
;
TX ; Check taxonomies
NEW TAX,DIC,X,TDA,Y
S DIC="^ATXAX(",DIC(0)="Z"
S TAX="BKMV EI MEDS",X=TAX D ^DIC S TDA=+Y
I TDA'=-1 D
. NEW DA,VALUE
. S DA(1)=TDA,DA=0
. F S DA=$O(^ATXAX(TDA,21,DA)) Q:'DA D
.. S VALUE=$P(^ATXAX(TDA,21,DA,0),U,1)
.. I VALUE=5201!(VALUE=83677)!(VALUE=84151) D
... S DIK="^ATXAX("_DA(1)_",21," D ^DIK
;
NEW TAX,DIC,X,TDA,Y
S DIC="^ATXAX(",DIC(0)="Z"
S TAX="BKMV NNRTI MEDS",X=TAX D ^DIC S TDA=+Y
I TDA'=-1 D
. NEW DA,VALUE
. S DA(1)=TDA,DA=0
. F S DA=$O(^ATXAX(TDA,21,DA)) Q:'DA D
.. S VALUE=$P(^ATXAX(TDA,21,DA,0),U,1)
.. I VALUE=84282!(VALUE=84317)!(VALUE=84318) D
... S DIK="^ATXAX("_DA(1)_",21," D ^DIK
;
NEW TAX,DIC,X,TDA,Y
S DIC="^ATXAX(",DIC(0)="Z"
S TAX="BKMV NRTI MEDS",X=TAX D ^DIC S TDA=+Y
I TDA'=-1 D
. NEW DA,VALUE
. S DA(1)=TDA,DA=0
. F S DA=$O(^ATXAX(TDA,21,DA)) Q:'DA D
.. S VALUE=$P(^ATXAX(TDA,21,DA,0),U,1)
.. I VALUE=83981!(VALUE=84378)!(VALUE=84431)!(VALUE=84317)!(VALUE=84089) D
... S DIK="^ATXAX("_DA(1)_",21," D ^DIK
;
NEW TAX,DIC,X,TDA,Y
S DIC="^ATXAX(",DIC(0)="Z"
S TAX="BKMV PI MEDS",X=TAX D ^DIC S TDA=+Y
I TDA'=-1 D
. NEW DA,VALUE
. S DA(1)=TDA,DA=0
. F S DA=$O(^ATXAX(TDA,21,DA)) Q:'DA D
.. S VALUE=$P(^ATXAX(TDA,21,DA,0),U,1)
.. I VALUE=84281!(VALUE=84374)!(VALUE=84318) D
... S DIK="^ATXAX("_DA(1)_",21," D ^DIK
Q
BKM100P1 ;PRXM/HC/ALA-BKM 1.00 Patch 1 ; 27 Sep 2006 10:29 AM
+1 ;;2.0;HIV MANAGEMENT SYSTEM;;May 29, 2009
+2 ;
CND ; Check candidate list and remove entries
+1 NEW DFN,MED,DFLG,STAT,TAX
+2 SET DFN=0
+3 FOR
SET DFN=$ORDER(^BKM(90451.2,DFN))
IF 'DFN
QUIT
Begin DoDot:1
+4 SET STAT=$PIECE(^BKM(90451.2,DFN,0),U,3)
+5 IF STAT="NOT"!(STAT="REM")
QUIT
+6 SET MED=0
SET DFLG=0
+7 FOR
SET MED=$ORDER(^BKM(90451.2,DFN,3,MED))
IF 'MED
QUIT
Begin DoDot:2
+8 SET TAX=$PIECE(^BKM(90451.2,DFN,3,MED,0),U,3)
+9 IF TAX="BKMV EI MEDS"!(TAX="BKMV NNRTI MEDS")!(TAX="BKMV NRTI MEDS")!(TAX="BKMV PI MEDS")
SET DFLG=1
QUIT
End DoDot:2
IF DFLG
QUIT
+10 IF DFLG
Begin DoDot:2
+11 NEW DA,DIK
+12 SET DA=DFN
SET DIK="^BKM(90451.2,"
DO ^DIK
End DoDot:2
End DoDot:1
+13 ;
TX ; Check taxonomies
+1 NEW TAX,DIC,X,TDA,Y
+2 SET DIC="^ATXAX("
SET DIC(0)="Z"
+3 SET TAX="BKMV EI MEDS"
SET X=TAX
DO ^DIC
SET TDA=+Y
+4 IF TDA'=-1
Begin DoDot:1
+5 NEW DA,VALUE
+6 SET DA(1)=TDA
SET DA=0
+7 FOR
SET DA=$ORDER(^ATXAX(TDA,21,DA))
IF 'DA
QUIT
Begin DoDot:2
+8 SET VALUE=$PIECE(^ATXAX(TDA,21,DA,0),U,1)
+9 IF VALUE=5201!(VALUE=83677)!(VALUE=84151)
Begin DoDot:3
+10 SET DIK="^ATXAX("_DA(1)_",21,"
DO ^DIK
End DoDot:3
End DoDot:2
End DoDot:1
+11 ;
+12 NEW TAX,DIC,X,TDA,Y
+13 SET DIC="^ATXAX("
SET DIC(0)="Z"
+14 SET TAX="BKMV NNRTI MEDS"
SET X=TAX
DO ^DIC
SET TDA=+Y
+15 IF TDA'=-1
Begin DoDot:1
+16 NEW DA,VALUE
+17 SET DA(1)=TDA
SET DA=0
+18 FOR
SET DA=$ORDER(^ATXAX(TDA,21,DA))
IF 'DA
QUIT
Begin DoDot:2
+19 SET VALUE=$PIECE(^ATXAX(TDA,21,DA,0),U,1)
+20 IF VALUE=84282!(VALUE=84317)!(VALUE=84318)
Begin DoDot:3
+21 SET DIK="^ATXAX("_DA(1)_",21,"
DO ^DIK
End DoDot:3
End DoDot:2
End DoDot:1
+22 ;
+23 NEW TAX,DIC,X,TDA,Y
+24 SET DIC="^ATXAX("
SET DIC(0)="Z"
+25 SET TAX="BKMV NRTI MEDS"
SET X=TAX
DO ^DIC
SET TDA=+Y
+26 IF TDA'=-1
Begin DoDot:1
+27 NEW DA,VALUE
+28 SET DA(1)=TDA
SET DA=0
+29 FOR
SET DA=$ORDER(^ATXAX(TDA,21,DA))
IF 'DA
QUIT
Begin DoDot:2
+30 SET VALUE=$PIECE(^ATXAX(TDA,21,DA,0),U,1)
+31 IF VALUE=83981!(VALUE=84378)!(VALUE=84431)!(VALUE=84317)!(VALUE=84089)
Begin DoDot:3
+32 SET DIK="^ATXAX("_DA(1)_",21,"
DO ^DIK
End DoDot:3
End DoDot:2
End DoDot:1
+33 ;
+34 NEW TAX,DIC,X,TDA,Y
+35 SET DIC="^ATXAX("
SET DIC(0)="Z"
+36 SET TAX="BKMV PI MEDS"
SET X=TAX
DO ^DIC
SET TDA=+Y
+37 IF TDA'=-1
Begin DoDot:1
+38 NEW DA,VALUE
+39 SET DA(1)=TDA
SET DA=0
+40 FOR
SET DA=$ORDER(^ATXAX(TDA,21,DA))
IF 'DA
QUIT
Begin DoDot:2
+41 SET VALUE=$PIECE(^ATXAX(TDA,21,DA,0),U,1)
+42 IF VALUE=84281!(VALUE=84374)!(VALUE=84318)
Begin DoDot:3
+43 SET DIK="^ATXAX("_DA(1)_",21,"
DO ^DIK
End DoDot:3
End DoDot:2
End DoDot:1
+44 QUIT
