ACDWIIF ;IHS/ADC/EDE/KML - SET LOC VARS FROM ACDIIF FILE;
;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
;***********************************************************
;//^ACDWDRV1, ^ACDWDRV3, ^ACDWCD1
;Needs ACDDA as internal DA to file entry
;*************************************************************
K ACDN0,ACDPROBP,ACDP,ACDDUA,ACDDUD,ACDDTA,ACDPTA,ACDDH,ACDAAR,ACDSUS,ACDPS,ACDES,ACDSS,ACDCS,ACDBS,ACDPLAR,ACDP,ACDPLAA,ACDIF,ACDSTAT,ACDHRS
S ACDN0=^ACDIIF(ACDDA,0)
S ACDPROBP=$P(ACDN0,U) S:'ACDPROBP ACDPROBP="NONE" S ACDPROBP=$S($D(^ACDPROB(ACDPROBP,0)):$P(^(0),U),1:"NONE")
;
S ACDP(3)=$P(ACDN0,U,3),ACDP(1)=9002170,ACDP(2)=2 S ACDCIT=$$SETS^ACDFUNC(.ACDP)
S ACDP(3)=$P(ACDN0,U,30),ACDP(1)=9002170,ACDP(2)=30 S ACDTOB=$$SETS^ACDFUNC(.ACDP)
S ACDDUA=$P(ACDN0,U,4)
S ACDDUD=$P(ACDN0,U,5)
S ACDOTHRS=$P(ACDN0,U,6) S:$G(ACDOTHRS)="" ACDOTHRS=.0001
I $D(^ACDIIF(ACDDA,2)) F ACDAE=0:0 S ACDAE=$O(^ACDIIF(ACDDA,2,ACDAE)) Q:'ACDAE I $D(^(ACDAE,0)) S ACDDTP=$P(^(0),U) S:'$D(^ACDDRUG(ACDDTP,0)) ACDDTP="XX" I ACDDTP'="XX" S ACDDTA($P(^ACDDRUG(ACDDTP,0),U,2)_"="_$P(^(0),U))=""
XXX ;
I $D(^ACDIIF(ACDDA,3)) F ACDAE=0:0 S ACDAE=$O(^ACDIIF(ACDDA,3,ACDAE)) Q:'ACDAE I $D(^(ACDAE,0)) S ACDPTP=$P(^(0),U) S:'$D(^ACDPROB(ACDPTP,0)) ACDPTP="XX" I ACDPTP'="XX" S ACDPTA($P(^ACDPROB(ACDPTP,0),U,2)_"="_$P(^(0),U))=""
S ACDHRS=$P(ACDN0,U,6)
S ACDDH=$P(ACDN0,U,7)
S ACDAAR=$P(ACDN0,U,8)
S ACDSUS=$P(ACDN0,U,10)
S ACDPS=$P(ACDN0,U,11)
S ACDES=$P(ACDN0,U,12)
S ACDSS=$P(ACDN0,U,13)
S ACDCS=$P(ACDN0,U,14)
S ACDBS=$P(ACDN0,U,15)
S ACDBV=$P(ACDN0,U,22)
S Y=0 F X="ACDSUS","ACDPS","ACDES","ACDSS","ACDCS","ACDBS","ACDBV" S:@X>0 Y=Y+1
S ACDSAVG=0
I Y S ACDSAVG=$J(((ACDSUS+ACDPS+ACDES+ACDSS+ACDCS+ACDBS+ACDBV)/Y),3,1)
S ACDPLAR=$P(ACDN0,U,16) S:'ACDPLAR ACDPLAR="NONE" S ACDPLAR=$S($D(^ACDCOMP(ACDPLAR,0)):$P(^(0),U),1:"NONE")
S ACDPLAR1=$P(ACDN0,U,17)
S ACDP(3)=$P(ACDN0,U,17),ACDP(1)=9002170,ACDP(2)=16 S ACDPLARL=$$SETS^ACDFUNC(.ACDP)
S ACDPLAA=$P(ACDN0,U,18) S:'ACDPLAA ACDPLAA="NONE" S ACDPLAA=$S($D(^ACDCOMP(ACDPLAA,0)):$P(^(0),U),1:"NONE")
S ACDPLAA1=$P(ACDN0,U,19)
S ACDP(3)=$P(ACDN0,U,19),ACDP(1)=9002170,ACDP(2)=18 S ACDPLAAL=$$SETS^ACDFUNC(.ACDP)
S ACDDIF=$P(ACDN0,U,20) S:'ACDDIF ACDDIF="NONE" S ACDDIF=$S($D(^ACDPLEX(ACDDIF,0)):$P(^(0),U),1:"NONE")
;
S ACDOTDIS=$P(ACDN0,U,21) I ACDOTDIS S ACDOTDIS=$S($D(^ACDPLEX(ACDOTDIS,0)):$P(^(0),U),1:"NF")
S ACDP(3)=$P(ACDN0,U,23),ACDP(1)=9002170,ACDP(2)=23 S ACDSTAT=$$SETS^ACDFUNC(.ACDP)
K ACDN0,X
ACDWIIF ;IHS/ADC/EDE/KML - SET LOC VARS FROM ACDIIF FILE;
+1 ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
+2 ;***********************************************************
+3 ;//^ACDWDRV1, ^ACDWDRV3, ^ACDWCD1
+4 ;Needs ACDDA as internal DA to file entry
+5 ;*************************************************************
+6 KILL ACDN0,ACDPROBP,ACDP,ACDDUA,ACDDUD,ACDDTA,ACDPTA,ACDDH,ACDAAR,ACDSUS,ACDPS,ACDES,ACDSS,ACDCS,ACDBS,ACDPLAR,ACDP,ACDPLAA,ACDIF,ACDSTAT,ACDHRS
+7 SET ACDN0=^ACDIIF(ACDDA,0)
+8 SET ACDPROBP=$PIECE(ACDN0,U)
IF 'ACDPROBP
SET ACDPROBP="NONE"
SET ACDPROBP=$SELECT($DATA(^ACDPROB(ACDPROBP,0)):$PIECE(^(0),U),1:"NONE")
+9 ;
+10 SET ACDP(3)=$PIECE(ACDN0,U,3)
SET ACDP(1)=9002170
SET ACDP(2)=2
SET ACDCIT=$$SETS^ACDFUNC(.ACDP)
+11 SET ACDP(3)=$PIECE(ACDN0,U,30)
SET ACDP(1)=9002170
SET ACDP(2)=30
SET ACDTOB=$$SETS^ACDFUNC(.ACDP)
+12 SET ACDDUA=$PIECE(ACDN0,U,4)
+13 SET ACDDUD=$PIECE(ACDN0,U,5)
+14 SET ACDOTHRS=$PIECE(ACDN0,U,6)
IF $GET(ACDOTHRS)=""
SET ACDOTHRS=.0001
+15 IF $DATA(^ACDIIF(ACDDA,2))
FOR ACDAE=0:0
SET ACDAE=$ORDER(^ACDIIF(ACDDA,2,ACDAE))
IF 'ACDAE
QUIT
IF $DATA(^(ACDAE,0))
SET ACDDTP=$PIECE(^(0),U)
IF '$DATA(^ACDDRUG(ACDDTP,0))
SET ACDDTP="XX"
IF ACDDTP'="XX"
SET ACDDTA($PIECE(^ACDDRUG(ACDDTP,0),U,2)_"="_$PIECE(^(0),U))=""
XXX ;
+1 IF $DATA(^ACDIIF(ACDDA,3))
FOR ACDAE=0:0
SET ACDAE=$ORDER(^ACDIIF(ACDDA,3,ACDAE))
IF 'ACDAE
QUIT
IF $DATA(^(ACDAE,0))
SET ACDPTP=$PIECE(^(0),U)
IF '$DATA(^ACDPROB(ACDPTP,0))
SET ACDPTP="XX"
IF ACDPTP'="XX"
SET ACDPTA($PIECE(^ACDPROB(ACDPTP,0),U,2)_"="_$PIECE(^(0),U))=""
+2 SET ACDHRS=$PIECE(ACDN0,U,6)
+3 SET ACDDH=$PIECE(ACDN0,U,7)
+4 SET ACDAAR=$PIECE(ACDN0,U,8)
+5 SET ACDSUS=$PIECE(ACDN0,U,10)
+6 SET ACDPS=$PIECE(ACDN0,U,11)
+7 SET ACDES=$PIECE(ACDN0,U,12)
+8 SET ACDSS=$PIECE(ACDN0,U,13)
+9 SET ACDCS=$PIECE(ACDN0,U,14)
+10 SET ACDBS=$PIECE(ACDN0,U,15)
+11 SET ACDBV=$PIECE(ACDN0,U,22)
+12 SET Y=0
FOR X="ACDSUS","ACDPS","ACDES","ACDSS","ACDCS","ACDBS","ACDBV"
IF @X>0
SET Y=Y+1
+13 SET ACDSAVG=0
+14 IF Y
SET ACDSAVG=$JUSTIFY(((ACDSUS+ACDPS+ACDES+ACDSS+ACDCS+ACDBS+ACDBV)/Y),3,1)
+15 SET ACDPLAR=$PIECE(ACDN0,U,16)
IF 'ACDPLAR
SET ACDPLAR="NONE"
SET ACDPLAR=$SELECT($DATA(^ACDCOMP(ACDPLAR,0)):$PIECE(^(0),U),1:"NONE")
+16 SET ACDPLAR1=$PIECE(ACDN0,U,17)
+17 SET ACDP(3)=$PIECE(ACDN0,U,17)
SET ACDP(1)=9002170
SET ACDP(2)=16
SET ACDPLARL=$$SETS^ACDFUNC(.ACDP)
+18 SET ACDPLAA=$PIECE(ACDN0,U,18)
IF 'ACDPLAA
SET ACDPLAA="NONE"
SET ACDPLAA=$SELECT($DATA(^ACDCOMP(ACDPLAA,0)):$PIECE(^(0),U),1:"NONE")
+19 SET ACDPLAA1=$PIECE(ACDN0,U,19)
+20 SET ACDP(3)=$PIECE(ACDN0,U,19)
SET ACDP(1)=9002170
SET ACDP(2)=18
SET ACDPLAAL=$$SETS^ACDFUNC(.ACDP)
+21 SET ACDDIF=$PIECE(ACDN0,U,20)
IF 'ACDDIF
SET ACDDIF="NONE"
SET ACDDIF=$SELECT($DATA(^ACDPLEX(ACDDIF,0)):$PIECE(^(0),U),1:"NONE")
+22 ;
+23 SET ACDOTDIS=$PIECE(ACDN0,U,21)
IF ACDOTDIS
SET ACDOTDIS=$SELECT($DATA(^ACDPLEX(ACDOTDIS,0)):$PIECE(^(0),U),1:"NF")
+24 SET ACDP(3)=$PIECE(ACDN0,U,23)
SET ACDP(1)=9002170
SET ACDP(2)=23
SET ACDSTAT=$$SETS^ACDFUNC(.ACDP)
+25 KILL ACDN0,X
