- ACDWTDC ;IHS/ADC/EDE/KML - SET LOC VARS FROM ACDTDC FILE;
- ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
- ;*********************************************************************
- ;//^ACDWDRV2, ^ACDWDRV3, ^ACDWCD2
- ;Needs ACDDA as internal DA to file entry
- ;********************************************************************
- K ACDN0,ACDPROBP,ACDPROBS,ACDDUA,ACDDUD,ACDDTA,ACDPTA,ACDDH,ACDAAR,ACDSUS,ACDPS,ACDES,ACDSS,ACDCS,ACDBS,ACDPLAR,ACDP,ACDPLAA,ACDIF,ACDID,ACDSTAT,ACDHRS
- S ACDN0=^ACDTDC(ACDDA,0)
- S ACDPROBP=$P(ACDN0,U,27) S:'ACDPROBP ACDPROBP="NONE" S ACDPROBP=$S($D(^ACDPROB(ACDPROBP,0)):$P(^(0),U),1:"NONE")
- S ACDPROBS=$P(ACDN0,U,28) S:'ACDPROBS ACDPROBS="NONE" S ACDPROBS=$S($D(^ACDPROB(ACDPROBS,0)):$P(^(0),U),1:"NONE")
- S ACDDUA=$P(ACDN0,U)
- S ACDDUD=$P(ACDN0,U,2)
- I $D(^ACDTDC(ACDDA,2)) F ACDAE=0:0 S ACDAE=$O(^ACDTDC(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(^ACDTDC(ACDDA,3)) F ACDAE=0:0 S ACDAE=$O(^ACDTDC(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 ACDDH=$P(ACDN0,U,4)
- S ACDAAR=$P(ACDN0,U,5)
- S ACDSUS=$P(ACDN0,U,7)
- S ACDPS=$P(ACDN0,U,8)
- S ACDES=$P(ACDN0,U,9)
- S ACDSS=$P(ACDN0,U,10)
- S ACDCS=$P(ACDN0,U,11)
- S ACDBS=$P(ACDN0,U,12)
- S ACDBV=$P(ACDN0,U,3)
- 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,13) S:'ACDPLAR ACDPLAR="NONE" S ACDPLAR=$S($D(^ACDCOMP(ACDPLAR,0)):$P(^(0),U),1:"NONE")
- S ACDPLAR1=$P(ACDN0,U,14)
- S ACDP(3)=$P(ACDN0,U,14),ACDP(1)=9002171,ACDP(2)=13 S ACDPLARL=$$SETS^ACDFUNC(.ACDP)
- S ACDPLAA=$P(ACDN0,U,15) S:'ACDPLAA ACDPLAA="NONE" S ACDPLAA=$S($D(^ACDCOMP(ACDPLAA,0)):$P(^(0),U),1:"NONE")
- S ACDPLAA1=$P(ACDN0,U,16)
- S ACDP(3)=$P(ACDN0,U,16),ACDP(1)=9002171,ACDP(2)=15 S ACDPLAAL=$$SETS^ACDFUNC(.ACDP)
- S ACDDIF=$P(ACDN0,U,17) S:'ACDDIF ACDDIF="NONE" S ACDDIF=$S($D(^ACDPLEX(ACDDIF,0)):$P(^(0),U),1:"NONE")
- S ACDID=$P(ACDN0,U,18)
- S ACDP(3)=$P(ACDN0,U,19),ACDP(1)=9002171,ACDP(2)=18 S ACDGA=$$SETS^ACDFUNC(.ACDP)
- S ACDP(3)=$P(ACDN0,U,20),ACDP(1)=9002171,ACDP(2)=19 S ACDTDCR=$$SETS^ACDFUNC(.ACDP)
- S ACDP(3)=$P(ACDN0,U,21),ACDP(1)=9002171,ACDP(2)=20 S ACDDAP=$$SETS^ACDFUNC(.ACDP)
- S ACDP(3)=$P(ACDN0,U,26),ACDP(1)=9002171,ACDP(2)=26 S ACDSTAT=$$SETS^ACDFUNC(.ACDP)
- S ACDHRS=$P(ACDN0,U,29)
- S ACDP(3)=$P(ACDN0,U,30),ACDP(1)=9002171,ACDP(2)=30 S ACDTOB=$$SETS^ACDFUNC(.ACDP)
- Q
- ACDWTDC ;IHS/ADC/EDE/KML - SET LOC VARS FROM ACDTDC FILE;
- +1 ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
- +2 ;*********************************************************************
- +3 ;//^ACDWDRV2, ^ACDWDRV3, ^ACDWCD2
- +4 ;Needs ACDDA as internal DA to file entry
- +5 ;********************************************************************
- +6 KILL ACDN0,ACDPROBP,ACDPROBS,ACDDUA,ACDDUD,ACDDTA,ACDPTA,ACDDH,ACDAAR,ACDSUS,ACDPS,ACDES,ACDSS,ACDCS,ACDBS,ACDPLAR,ACDP,ACDPLAA,ACDIF,ACDID,ACDSTAT,ACDHRS
- +7 SET ACDN0=^ACDTDC(ACDDA,0)
- +8 SET ACDPROBP=$PIECE(ACDN0,U,27)
- IF 'ACDPROBP
- SET ACDPROBP="NONE"
- SET ACDPROBP=$SELECT($DATA(^ACDPROB(ACDPROBP,0)):$PIECE(^(0),U),1:"NONE")
- +9 SET ACDPROBS=$PIECE(ACDN0,U,28)
- IF 'ACDPROBS
- SET ACDPROBS="NONE"
- SET ACDPROBS=$SELECT($DATA(^ACDPROB(ACDPROBS,0)):$PIECE(^(0),U),1:"NONE")
- +10 SET ACDDUA=$PIECE(ACDN0,U)
- +11 SET ACDDUD=$PIECE(ACDN0,U,2)
- +12 IF $DATA(^ACDTDC(ACDDA,2))
- FOR ACDAE=0:0
- SET ACDAE=$ORDER(^ACDTDC(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(^ACDTDC(ACDDA,3))
- FOR ACDAE=0:0
- SET ACDAE=$ORDER(^ACDTDC(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 ACDDH=$PIECE(ACDN0,U,4)
- +3 SET ACDAAR=$PIECE(ACDN0,U,5)
- +4 SET ACDSUS=$PIECE(ACDN0,U,7)
- +5 SET ACDPS=$PIECE(ACDN0,U,8)
- +6 SET ACDES=$PIECE(ACDN0,U,9)
- +7 SET ACDSS=$PIECE(ACDN0,U,10)
- +8 SET ACDCS=$PIECE(ACDN0,U,11)
- +9 SET ACDBS=$PIECE(ACDN0,U,12)
- +10 SET ACDBV=$PIECE(ACDN0,U,3)
- +11 SET Y=0
- FOR X="ACDSUS","ACDPS","ACDES","ACDSS","ACDCS","ACDBS","ACDBV"
- IF @X>0
- SET Y=Y+1
- +12 SET ACDSAVG=0
- +13 IF Y
- SET ACDSAVG=$JUSTIFY(((ACDSUS+ACDPS+ACDES+ACDSS+ACDCS+ACDBS+ACDBV)/Y),3,1)
- +14 SET ACDPLAR=$PIECE(ACDN0,U,13)
- IF 'ACDPLAR
- SET ACDPLAR="NONE"
- SET ACDPLAR=$SELECT($DATA(^ACDCOMP(ACDPLAR,0)):$PIECE(^(0),U),1:"NONE")
- +15 SET ACDPLAR1=$PIECE(ACDN0,U,14)
- +16 SET ACDP(3)=$PIECE(ACDN0,U,14)
- SET ACDP(1)=9002171
- SET ACDP(2)=13
- SET ACDPLARL=$$SETS^ACDFUNC(.ACDP)
- +17 SET ACDPLAA=$PIECE(ACDN0,U,15)
- IF 'ACDPLAA
- SET ACDPLAA="NONE"
- SET ACDPLAA=$SELECT($DATA(^ACDCOMP(ACDPLAA,0)):$PIECE(^(0),U),1:"NONE")
- +18 SET ACDPLAA1=$PIECE(ACDN0,U,16)
- +19 SET ACDP(3)=$PIECE(ACDN0,U,16)
- SET ACDP(1)=9002171
- SET ACDP(2)=15
- SET ACDPLAAL=$$SETS^ACDFUNC(.ACDP)
- +20 SET ACDDIF=$PIECE(ACDN0,U,17)
- IF 'ACDDIF
- SET ACDDIF="NONE"
- SET ACDDIF=$SELECT($DATA(^ACDPLEX(ACDDIF,0)):$PIECE(^(0),U),1:"NONE")
- +21 SET ACDID=$PIECE(ACDN0,U,18)
- +22 SET ACDP(3)=$PIECE(ACDN0,U,19)
- SET ACDP(1)=9002171
- SET ACDP(2)=18
- SET ACDGA=$$SETS^ACDFUNC(.ACDP)
- +23 SET ACDP(3)=$PIECE(ACDN0,U,20)
- SET ACDP(1)=9002171
- SET ACDP(2)=19
- SET ACDTDCR=$$SETS^ACDFUNC(.ACDP)
- +24 SET ACDP(3)=$PIECE(ACDN0,U,21)
- SET ACDP(1)=9002171
- SET ACDP(2)=20
- SET ACDDAP=$$SETS^ACDFUNC(.ACDP)
- +25 SET ACDP(3)=$PIECE(ACDN0,U,26)
- SET ACDP(1)=9002171
- SET ACDP(2)=26
- SET ACDSTAT=$$SETS^ACDFUNC(.ACDP)
- +26 SET ACDHRS=$PIECE(ACDN0,U,29)
- +27 SET ACDP(3)=$PIECE(ACDN0,U,30)
- SET ACDP(1)=9002171
- SET ACDP(2)=30
- SET ACDTOB=$$SETS^ACDFUNC(.ACDP)
- +28 QUIT
