ACDRLU2 ;IHS/ADC/EDE/KML - UTILITY ROUTINE;
;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
;
DATA(V,F,F1,F2) ;EP - get data item
I $G(F)="" S F="E"
NEW %,I
S %=""
I $G(F1)="" Q %
I $G(F2)="" Q %
I $D(^ACDIIF("C",V)) D Q %
.S I=$O(^ACDIIF("C",V,0))
.S %=$S(F="I":$$VALI^XBDIQ1(9002170,I,F1),1:$$VAL^XBDIQ1(9002170,I,F1))
.Q
I $D(^ACDTDC("C",V)) D Q %
.S I=$O(^ACDTDC("C",V,0))
.S %=$S(F="I":$$VALI^XBDIQ1(9002171,I,F2),1:$$VAL^XBDIQ1(9002171,I,F2))
.Q
Q %
DRUG ;EP
K X
NEW %,I,%1
S %=""
I $D(^ACDIIF("C",ACDR)) D Q
.S I=$O(^ACDIIF("C",ACDR,0))
.S %1=0 F S %1=$O(^ACDIIF(I,2,%1)) Q:%1'=+%1 S X($P(^ACDIIF(I,2,%1,0),U))=""
.Q
I $D(^ACDTDC("C",ACDR)) D Q
.S I=$O(^ACDTDC("C",ACDR,0))
.S %1=0 F S %1=$O(^ACDTDC(I,2,%1)) Q:%1'=+%1 S X($P(^ACDTDC(I,2,%1,0),U))=""
.Q
Q
DRUGP ;EP
K ACDPRNM
S ACDPCNT=0
NEW %,I,%1
S %=""
I $D(^ACDIIF("C",ACDR)) D Q
.S I=$O(^ACDIIF("C",ACDR,0))
.S %1=0 F S %1=$O(^ACDIIF(I,2,%1)) Q:%1'=+%1 S ACDPCNT=ACDPCNT+1,ACDPRNM(ACDPCNT)=$P(^ACDDRUG($P(^ACDIIF(I,2,%1,0),U),0),U)
.Q
I $D(^ACDTDC("C",ACDR)) D Q
.S I=$O(^ACDTDC("C",ACDR,0))
.S %1=0 F S %1=$O(^ACDTDC(I,2,%1)) Q:%1'=+%1 S ACDPCNT=ACDPCNT+1,ACDPRNM(ACDPCNT)=$P(^ACDDRUG($P(^ACDTDC(I,2,%1,0),U),0),U)
.Q
Q
OTHPROB ;EP
K X
NEW %,I,%1
S %=""
I $D(^ACDIIF("C",ACDR)) D Q
.S I=$O(^ACDIIF("C",ACDR,0))
.S %1=0 F S %1=$O(^ACDIIF(I,3,%1)) Q:%1'=+%1 S X($P(^ACDIIF(I,3,%1,0),U))=""
.Q
I $D(^ACDTDC("C",ACDR)) D Q
.S I=$O(^ACDTDC("C",ACDR,0))
.S %1=0 F S %1=$O(^ACDTDC(I,3,%1)) Q:%1'=+%1 S X($P(^ACDTDC(I,3,%1,0),U))=""
.Q
Q
OTHPROBP ;EP
K ACDPRNM
S ACDPCNT=0
NEW %,I,%1
S %=""
I $D(^ACDIIF("C",ACDR)) D Q
.S I=$O(^ACDIIF("C",ACDR,0))
.S %1=0 F S %1=$O(^ACDIIF(I,3,%1)) Q:%1'=+%1 S ACDPCNT=ACDPCNT+1,ACDPRNM(ACDPCNT)=$P(^ACDPROB($P(^ACDIIF(I,3,%1,0),U),0),U)
.Q
I $D(^ACDTDC("C",ACDR)) D Q
.S I=$O(^ACDTDC("C",ACDR,0))
.S %1=0 F S %1=$O(^ACDTDC(I,3,%1)) Q:%1'=+%1 S ACDPCNT=ACDPCNT+1,ACDPRNM(ACDPCNT)=$P(^ACDPROB($P(^ACDTDC(I,3,%1,0),U),0),U)
.Q
Q
HOURS ;EP
K X
NEW %,I,%1
S %=""
I $D(^ACDIIF("C",ACDR)) D Q
.S I=$O(^ACDIIF("C",ACDR,0))
.S X=$$VALI^XBDIQ1(9002170,I,102) I X S X(X)=""
.Q
I $D(^ACDTDC("C",ACDR)) D Q
.S I=$O(^ACDTDC("C",ACDR,0))
.S X=$$VALI^XBDIQ1(9002171,I,29) I X S X(X)=""
.Q
I $D(^ACDCS("C",ACDR)) D
.S I=0 F S I=$O(^ACDCS("C",ACDR,I)) Q:I'=+I S Y=$$VALI^XBDIQ1(9002172,I,3) I Y S X(Y)=""
HOURSP ;EP
K X
NEW %,I,%1
S %=""
I $D(^ACDIIF("C",ACDR)) D Q
.S I=$O(^ACDIIF("C",ACDR,0))
.S X=$$VAL^XBDIQ1(9002170,I,102) I X S ACDPRNM(1)=X
.Q
I $D(^ACDTDC("C",ACDR)) D Q
.S I=$O(^ACDTDC("C",ACDR,0))
.S X=$$VAL^XBDIQ1(9002171,I,29) I X S ACDPRNM(1)=X
.Q
I $D(^ACDCS("C",ACDR)) D
.S I=0 F S I=$O(^ACDCS("C",ACDR,I)) Q:I'=+I S Y=$$VAL^XBDIQ1(9002172,I,3) I Y S ACDPCNT=ACDPCNT+1,ACDPRNM(ACDPCNT)=Y
Q
PPPROB ;EP - called from patient lister
;sets X(ien of problem) equal to all primary problems this patient
;had between ACDBD and ACDED (beginning and ending dates)
Q:'$G(DFN) ;no patient passed
K X
NEW Y,V,I
S V=0 F S V=$O(^ACDVIS("D",DFN,V)) Q:V'=+V S I=$P($P(^ACDVIS(V,0),U),".") I I'<ACDBD,I'>ACDED D
.S Y=0 F S Y=$O(^ACDIIF("C",V,Y)) Q:Y'=+Y S X($P(^ACDIIF(Y,0),U))=""
Q
PAPROB ;EP - called from patient list
;sets X(ien of problem) equal to all other problems this patient
;had between ACDBD and ACDED (beginning and ending dates)
Q:'$G(DFN) ;no patient passed
K X
NEW Y,V,I,A,B
S V=0 F S V=$O(^ACDVIS("D",DFN,V)) Q:V'=+V S I=$P($P(^ACDVIS(V,0),U),".") I I'<ACDBD,I'>ACDED D
.S I=0 F S I=$O(^ACDIIF("C",V,I)) Q:I'=+I D
..S %=0 F S %=$O(^ACDIIF(I,3,%)) Q:%'=+% S X($P(^ACDIIF(I,3,%,0),U))=""
.S I=0 F S I=$O(^ACDTDC("C",ACDR,I)) Q:I'=+I D
..S %=0 F S %=$O(^ACDTDC(I,3,%)) Q:%'=+% S X($P(^ACDTDC(I,3,%,0),U))=""
Q
PPPROV ;EP - called from patient lister
;sets X(ien of problem) equal to all primary providers this patient
;had between ACDBD and ACDED (beginning and ending dates)
Q:'$G(DFN) ;no patient passed
K X
NEW Y,V,I
S V=0 F S V=$O(^ACDVIS("D",DFN,V)) Q:V'=+V S I=$P($P(^ACDVIS(V,0),U),".") I I'<ACDBD,I'>ACDED I $P(^ACDVIS(V,0),U,3) S X($P(^ACDVIS(V,0),U,3))=""
Q
PCOMPC ;EP
;sets X(ien of problem) equal to all components this patient
;had between ACDBD and ACDED (beginning and ending dates)
Q:'$G(DFN) ;no patient passed
K X
NEW Y,V,I
S V=0 F S V=$O(^ACDVIS("D",DFN,V)) Q:V'=+V S I=$P($P(^ACDVIS(V,0),U),".") I I'<ACDBD,I'>ACDED I $P(^ACDVIS(V,0),U,2)]"" S X($P(^ACDVIS(V,0),U,2))=""
Q
PCOMPT ;EP
;sets X(ien of problem) equal to all component types this patient
;had between ACDBD and ACDED (beginning and ending dates)
Q:'$G(DFN) ;no patient passed
K X
NEW Y,V,I
S V=0 F S V=$O(^ACDVIS("D",DFN,V)) Q:V'=+V S I=$P($P(^ACDVIS(V,0),U),".") I I'<ACDBD,I'>ACDED I $P(^ACDVIS(V,0),U,7)]"" S X($P(^ACDVIS(V,0),U,7))=""
Q
PDRUG ;EP
;sets X(ien of problem) equal to all drug types this patient
;had between ACDBD and ACDED (beginning and ending dates)
Q:'$G(DFN) ;no patient passed
K X
NEW Y,V,I,A,B
S V=0 F S V=$O(^ACDVIS("D",DFN,V)) Q:V'=+V S I=$P($P(^ACDVIS(V,0),U),".") I I'<ACDBD,I'>ACDED D
.S I=0 F S I=$O(^ACDIIF("C",V,I)) Q:I'=+I D
..S %=0 F S %=$O(^ACDIIF(I,2,%)) Q:%'=+% S X($P(^ACDIIF(I,2,%,0),U))=""
.S I=0 F S I=$O(^ACDTDC("C",ACDR,I)) Q:I'=+I D
..S %=0 F S %=$O(^ACDTDC(I,2,%)) Q:%'=+% S X($P(^ACDTDC(I,2,%,0),U))=""
Q
ACDRLU2 ;IHS/ADC/EDE/KML - UTILITY ROUTINE;
+1 ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
+2 ;
DATA(V,F,F1,F2) ;EP - get data item
+1 IF $GET(F)=""
SET F="E"
+2 NEW %,I
+3 SET %=""
+4 IF $GET(F1)=""
QUIT %
+5 IF $GET(F2)=""
QUIT %
+6 IF $DATA(^ACDIIF("C",V))
Begin DoDot:1
+7 SET I=$ORDER(^ACDIIF("C",V,0))
+8 SET %=$SELECT(F="I":$$VALI^XBDIQ1(9002170,I,F1),1:$$VAL^XBDIQ1(9002170,I,F1))
+9 QUIT
End DoDot:1
QUIT %
+10 IF $DATA(^ACDTDC("C",V))
Begin DoDot:1
+11 SET I=$ORDER(^ACDTDC("C",V,0))
+12 SET %=$SELECT(F="I":$$VALI^XBDIQ1(9002171,I,F2),1:$$VAL^XBDIQ1(9002171,I,F2))
+13 QUIT
End DoDot:1
QUIT %
+14 QUIT %
DRUG ;EP
+1 KILL X
+2 NEW %,I,%1
+3 SET %=""
+4 IF $DATA(^ACDIIF("C",ACDR))
Begin DoDot:1
+5 SET I=$ORDER(^ACDIIF("C",ACDR,0))
+6 SET %1=0
FOR
SET %1=$ORDER(^ACDIIF(I,2,%1))
IF %1'=+%1
QUIT
SET X($PIECE(^ACDIIF(I,2,%1,0),U))=""
+7 QUIT
End DoDot:1
QUIT
+8 IF $DATA(^ACDTDC("C",ACDR))
Begin DoDot:1
+9 SET I=$ORDER(^ACDTDC("C",ACDR,0))
+10 SET %1=0
FOR
SET %1=$ORDER(^ACDTDC(I,2,%1))
IF %1'=+%1
QUIT
SET X($PIECE(^ACDTDC(I,2,%1,0),U))=""
+11 QUIT
End DoDot:1
QUIT
+12 QUIT
DRUGP ;EP
+1 KILL ACDPRNM
+2 SET ACDPCNT=0
+3 NEW %,I,%1
+4 SET %=""
+5 IF $DATA(^ACDIIF("C",ACDR))
Begin DoDot:1
+6 SET I=$ORDER(^ACDIIF("C",ACDR,0))
+7 SET %1=0
FOR
SET %1=$ORDER(^ACDIIF(I,2,%1))
IF %1'=+%1
QUIT
SET ACDPCNT=ACDPCNT+1
SET ACDPRNM(ACDPCNT)=$PIECE(^ACDDRUG($PIECE(^ACDIIF(I,2,%1,0),U),0),U)
+8 QUIT
End DoDot:1
QUIT
+9 IF $DATA(^ACDTDC("C",ACDR))
Begin DoDot:1
+10 SET I=$ORDER(^ACDTDC("C",ACDR,0))
+11 SET %1=0
FOR
SET %1=$ORDER(^ACDTDC(I,2,%1))
IF %1'=+%1
QUIT
SET ACDPCNT=ACDPCNT+1
SET ACDPRNM(ACDPCNT)=$PIECE(^ACDDRUG($PIECE(^ACDTDC(I,2,%1,0),U),0),U)
+12 QUIT
End DoDot:1
QUIT
+13 QUIT
OTHPROB ;EP
+1 KILL X
+2 NEW %,I,%1
+3 SET %=""
+4 IF $DATA(^ACDIIF("C",ACDR))
Begin DoDot:1
+5 SET I=$ORDER(^ACDIIF("C",ACDR,0))
+6 SET %1=0
FOR
SET %1=$ORDER(^ACDIIF(I,3,%1))
IF %1'=+%1
QUIT
SET X($PIECE(^ACDIIF(I,3,%1,0),U))=""
+7 QUIT
End DoDot:1
QUIT
+8 IF $DATA(^ACDTDC("C",ACDR))
Begin DoDot:1
+9 SET I=$ORDER(^ACDTDC("C",ACDR,0))
+10 SET %1=0
FOR
SET %1=$ORDER(^ACDTDC(I,3,%1))
IF %1'=+%1
QUIT
SET X($PIECE(^ACDTDC(I,3,%1,0),U))=""
+11 QUIT
End DoDot:1
QUIT
+12 QUIT
OTHPROBP ;EP
+1 KILL ACDPRNM
+2 SET ACDPCNT=0
+3 NEW %,I,%1
+4 SET %=""
+5 IF $DATA(^ACDIIF("C",ACDR))
Begin DoDot:1
+6 SET I=$ORDER(^ACDIIF("C",ACDR,0))
+7 SET %1=0
FOR
SET %1=$ORDER(^ACDIIF(I,3,%1))
IF %1'=+%1
QUIT
SET ACDPCNT=ACDPCNT+1
SET ACDPRNM(ACDPCNT)=$PIECE(^ACDPROB($PIECE(^ACDIIF(I,3,%1,0),U),0),U)
+8 QUIT
End DoDot:1
QUIT
+9 IF $DATA(^ACDTDC("C",ACDR))
Begin DoDot:1
+10 SET I=$ORDER(^ACDTDC("C",ACDR,0))
+11 SET %1=0
FOR
SET %1=$ORDER(^ACDTDC(I,3,%1))
IF %1'=+%1
QUIT
SET ACDPCNT=ACDPCNT+1
SET ACDPRNM(ACDPCNT)=$PIECE(^ACDPROB($PIECE(^ACDTDC(I,3,%1,0),U),0),U)
+12 QUIT
End DoDot:1
QUIT
+13 QUIT
HOURS ;EP
+1 KILL X
+2 NEW %,I,%1
+3 SET %=""
+4 IF $DATA(^ACDIIF("C",ACDR))
Begin DoDot:1
+5 SET I=$ORDER(^ACDIIF("C",ACDR,0))
+6 SET X=$$VALI^XBDIQ1(9002170,I,102)
IF X
SET X(X)=""
+7 QUIT
End DoDot:1
QUIT
+8 IF $DATA(^ACDTDC("C",ACDR))
Begin DoDot:1
+9 SET I=$ORDER(^ACDTDC("C",ACDR,0))
+10 SET X=$$VALI^XBDIQ1(9002171,I,29)
IF X
SET X(X)=""
+11 QUIT
End DoDot:1
QUIT
+12 IF $DATA(^ACDCS("C",ACDR))
Begin DoDot:1
+13 SET I=0
FOR
SET I=$ORDER(^ACDCS("C",ACDR,I))
IF I'=+I
QUIT
SET Y=$$VALI^XBDIQ1(9002172,I,3)
IF Y
SET X(Y)=""
End DoDot:1
HOURSP ;EP
+1 KILL X
+2 NEW %,I,%1
+3 SET %=""
+4 IF $DATA(^ACDIIF("C",ACDR))
Begin DoDot:1
+5 SET I=$ORDER(^ACDIIF("C",ACDR,0))
+6 SET X=$$VAL^XBDIQ1(9002170,I,102)
IF X
SET ACDPRNM(1)=X
+7 QUIT
End DoDot:1
QUIT
+8 IF $DATA(^ACDTDC("C",ACDR))
Begin DoDot:1
+9 SET I=$ORDER(^ACDTDC("C",ACDR,0))
+10 SET X=$$VAL^XBDIQ1(9002171,I,29)
IF X
SET ACDPRNM(1)=X
+11 QUIT
End DoDot:1
QUIT
+12 IF $DATA(^ACDCS("C",ACDR))
Begin DoDot:1
+13 SET I=0
FOR
SET I=$ORDER(^ACDCS("C",ACDR,I))
IF I'=+I
QUIT
SET Y=$$VAL^XBDIQ1(9002172,I,3)
IF Y
SET ACDPCNT=ACDPCNT+1
SET ACDPRNM(ACDPCNT)=Y
End DoDot:1
+14 QUIT
PPPROB ;EP - called from patient lister
+1 ;sets X(ien of problem) equal to all primary problems this patient
+2 ;had between ACDBD and ACDED (beginning and ending dates)
+3 ;no patient passed
IF '$GET(DFN)
QUIT
+4 KILL X
+5 NEW Y,V,I
+6 SET V=0
FOR
SET V=$ORDER(^ACDVIS("D",DFN,V))
IF V'=+V
QUIT
SET I=$PIECE($PIECE(^ACDVIS(V,0),U),".")
IF I'<ACDBD
IF I'>ACDED
Begin DoDot:1
+7 SET Y=0
FOR
SET Y=$ORDER(^ACDIIF("C",V,Y))
IF Y'=+Y
QUIT
SET X($PIECE(^ACDIIF(Y,0),U))=""
End DoDot:1
+8 QUIT
PAPROB ;EP - called from patient list
+1 ;sets X(ien of problem) equal to all other problems this patient
+2 ;had between ACDBD and ACDED (beginning and ending dates)
+3 ;no patient passed
IF '$GET(DFN)
QUIT
+4 KILL X
+5 NEW Y,V,I,A,B
+6 SET V=0
FOR
SET V=$ORDER(^ACDVIS("D",DFN,V))
IF V'=+V
QUIT
SET I=$PIECE($PIECE(^ACDVIS(V,0),U),".")
IF I'<ACDBD
IF I'>ACDED
Begin DoDot:1
+7 SET I=0
FOR
SET I=$ORDER(^ACDIIF("C",V,I))
IF I'=+I
QUIT
Begin DoDot:2
+8 SET %=0
FOR
SET %=$ORDER(^ACDIIF(I,3,%))
IF %'=+%
QUIT
SET X($PIECE(^ACDIIF(I,3,%,0),U))=""
End DoDot:2
+9 SET I=0
FOR
SET I=$ORDER(^ACDTDC("C",ACDR,I))
IF I'=+I
QUIT
Begin DoDot:2
+10 SET %=0
FOR
SET %=$ORDER(^ACDTDC(I,3,%))
IF %'=+%
QUIT
SET X($PIECE(^ACDTDC(I,3,%,0),U))=""
End DoDot:2
End DoDot:1
+11 QUIT
PPPROV ;EP - called from patient lister
+1 ;sets X(ien of problem) equal to all primary providers this patient
+2 ;had between ACDBD and ACDED (beginning and ending dates)
+3 ;no patient passed
IF '$GET(DFN)
QUIT
+4 KILL X
+5 NEW Y,V,I
+6 SET V=0
FOR
SET V=$ORDER(^ACDVIS("D",DFN,V))
IF V'=+V
QUIT
SET I=$PIECE($PIECE(^ACDVIS(V,0),U),".")
IF I'<ACDBD
IF I'>ACDED
IF $PIECE(^ACDVIS(V,0),U,3)
SET X($PIECE(^ACDVIS(V,0),U,3))=""
+7 QUIT
PCOMPC ;EP
+1 ;sets X(ien of problem) equal to all components this patient
+2 ;had between ACDBD and ACDED (beginning and ending dates)
+3 ;no patient passed
IF '$GET(DFN)
QUIT
+4 KILL X
+5 NEW Y,V,I
+6 SET V=0
FOR
SET V=$ORDER(^ACDVIS("D",DFN,V))
IF V'=+V
QUIT
SET I=$PIECE($PIECE(^ACDVIS(V,0),U),".")
IF I'<ACDBD
IF I'>ACDED
IF $PIECE(^ACDVIS(V,0),U,2)]""
SET X($PIECE(^ACDVIS(V,0),U,2))=""
+7 QUIT
PCOMPT ;EP
+1 ;sets X(ien of problem) equal to all component types this patient
+2 ;had between ACDBD and ACDED (beginning and ending dates)
+3 ;no patient passed
IF '$GET(DFN)
QUIT
+4 KILL X
+5 NEW Y,V,I
+6 SET V=0
FOR
SET V=$ORDER(^ACDVIS("D",DFN,V))
IF V'=+V
QUIT
SET I=$PIECE($PIECE(^ACDVIS(V,0),U),".")
IF I'<ACDBD
IF I'>ACDED
IF $PIECE(^ACDVIS(V,0),U,7)]""
SET X($PIECE(^ACDVIS(V,0),U,7))=""
+7 QUIT
PDRUG ;EP
+1 ;sets X(ien of problem) equal to all drug types this patient
+2 ;had between ACDBD and ACDED (beginning and ending dates)
+3 ;no patient passed
IF '$GET(DFN)
QUIT
+4 KILL X
+5 NEW Y,V,I,A,B
+6 SET V=0
FOR
SET V=$ORDER(^ACDVIS("D",DFN,V))
IF V'=+V
QUIT
SET I=$PIECE($PIECE(^ACDVIS(V,0),U),".")
IF I'<ACDBD
IF I'>ACDED
Begin DoDot:1
+7 SET I=0
FOR
SET I=$ORDER(^ACDIIF("C",V,I))
IF I'=+I
QUIT
Begin DoDot:2
+8 SET %=0
FOR
SET %=$ORDER(^ACDIIF(I,2,%))
IF %'=+%
QUIT
SET X($PIECE(^ACDIIF(I,2,%,0),U))=""
End DoDot:2
+9 SET I=0
FOR
SET I=$ORDER(^ACDTDC("C",ACDR,I))
IF I'=+I
QUIT
Begin DoDot:2
+10 SET %=0
FOR
SET %=$ORDER(^ACDTDC(I,2,%))
IF %'=+%
QUIT
SET X($PIECE(^ACDTDC(I,2,%,0),U))=""
End DoDot:2
End DoDot:1
+11 QUIT
