- 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