ACDWCINV ;IHS/ADC/EDE/KML - SET LOC VARS FROM ACDINTV FILE;
;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
EN ;
;//^ACDWDRV3
;//^ACDWCD4
;*********************************************************************
;//
;Needs ACDDA as internal DA to file entry
;********************************************************************
K ACDPTA,ACDPG,ACDAUF,ACDN0,Y,ACDDFN,ACDDFNP,ACDTRIB,ACDP,ACDSEX,ACDAGE,ACDINVR,ACDCOMC,ACDCONT,ACDPROBP,ACDINVSH,ACDPLAA,ACDPLAA1,ACDPLAR,ACDPLAR1,ACDINVPP,ACDINVCT,ACDINVTD,ACDINVTC,ACDPROVA
S ACDN0=^ACDINTV(ACDDA,0)
S ACDPG=$P(ACDN0,U,17),ACDPG=$P(^ACDF5PI(ACDPG,0),U),ACDPG=$P(^AUTTLOC(ACDPG,0),U),ACDAUF=$P(^(0),U,10),ACDPG=$P(^DIC(4,ACDPG,0),U)
S Y=$P(ACDN0,U) S ACDCLIV=$$DD^ACDFUNC(Y)
S (ACDDFN,ACDDFNP)=$P(ACDN0,U,2) S:'ACDDFN ACDDFN="NONE",ACDDFNP=0 S ACDDFN=$S($D(^DPT(ACDDFN,0)):$P(^(0),U),1:"NONE")
I $G(ACDDFNP)'=0 S ACDDFNP=1_ACDAUF_ACDDFNP
S ACDTRIB=$P(ACDN0,U,3) S:ACDTRIB="" ACDTRIB="UNKNOWN"
S ACDP(3)=$P(ACDN0,U,4),ACDP(2)=3,ACDP(1)=9002173.5 S ACDSEX=$$SETS^ACDFUNC(.ACDP)
S ACDAGE=$P(ACDN0,U,5)
S ACDINVR=$P(ACDN0,U,6)
;
S ACDCOMC="INTERVENTIONS" ; not really in CDMIS COMPONENT file
S ACDCOMCS="INT"
S ACDCOMCL="INTERVENTIONS"
S (ACDCOMT,ACDP(3))=$P(ACDN0,U,7),ACDP(1)=9002173.5,ACDP(2)=17 S ACDCOMTL=$$SETS^ACDFUNC(.ACDP)
S ACDPROBP=$P(ACDN0,U,8) S:'ACDPROBP ACDPROBP="NONE" S ACDPROBP=$S($D(^ACDPROB(ACDPROBP,0)):$P(^(0),U),1:"NONE")
S ACDINVSH=$P(ACDN0,U,9)
S ACDPLAR=$P(ACDN0,U,10) S:'ACDPLAR ACDPLAR="NONE" S ACDPLAR=$S($D(^ACDCOMP(ACDPLAR,0)):$P(^(0),U),1:"NONE")
S ACDP(3)=$P(ACDN0,U,19),ACDP(1)=9002173.5,ACDP(2)=21 S ACDPLAR1=$$SETS^ACDFUNC(.ACDP)
S ACDPLAA=$P(ACDN0,U,11) S:'ACDPLAA ACDPLAA="NONE" S ACDPLAA=$S($D(^ACDCOMP(ACDPLAA,0)):$P(^(0),U),1:"NONE")
S ACDP(3)=$P(ACDN0,U,18),ACDP(1)=9002173.5,ACDP(2)=20 S ACDPLAA1=$$SETS^ACDFUNC(.ACDP)
S ACDDIF=$P(ACDN0,U,12) S:'ACDDIF ACDDIF="NONE" S ACDDIF=$S($D(^ACDPLEX(ACDDIF,0)):$P(^(0),U),1:"NONE")
S ACDINVPP=$P(ACDN0,U,13)
S ACDINVCT=$P(ACDN0,U,14)
S ACDINVTD=$P(ACDN0,U,15)
S ACDP(3)=$P(ACDN0,U,16),ACDP(2)=18,ACDP(1)=9002173.5 S ACDINVTC=$$SETS^ACDFUNC(.ACDP)
I $D(^ACDINTV(ACDDA,1)) F ACDAE=0:0 S ACDAE=$O(^ACDINTV(ACDDA,1,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 ACDCONT="INTERVENTIONS" ; not really a contact type
S ACDCONTL="INTERVENTIONS"
S ACDSTATE=$P(ACDN0,U,20) S:ACDSTATE="" ACDSTATE="UNKNOWN"
S ACDP(3)=$P(ACDN0,U,23),ACDP1(1)=9002173.5,ACDP(2)=25 S ACDVET=$$SETS^ACDFUNC(.ACDP)
;I $D(^ACDINTV(ACDDA,2)) F ACDAE=0:0 S ACDAE=$O(^ACDINTV(ACDDA,2,ACDAE)) Q:'ACDAE I $D(^(ACDAE,0)) S ACDPTP=$P(^(0),U) S:'$D(^DIC(16,ACDPTP,0)) ACDPTP="XX" I ACDPTP'="XX" S ACDPROVA($P(^DIC(16,ACDPTP,0),U))=""
I $D(^ACDINTV(ACDDA,2)) F ACDAE=0:0 S ACDAE=$O(^ACDINTV(ACDDA,2,ACDAE)) Q:'ACDAE I $D(^(ACDAE,0)) S ACDPTP=$P(^(0),U) S:'$D(^VA(200,ACDPTP,0)) ACDPTP="XX" I ACDPTP'="XX" S ACDPROVA($P(^VA(200,ACDPTP,0),U))=""
Q
ACDWCINV ;IHS/ADC/EDE/KML - SET LOC VARS FROM ACDINTV FILE;
+1 ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
EN ;
+1 ;//^ACDWDRV3
+2 ;//^ACDWCD4
+3 ;*********************************************************************
+4 ;//
+5 ;Needs ACDDA as internal DA to file entry
+6 ;********************************************************************
+7 KILL ACDPTA,ACDPG,ACDAUF,ACDN0,Y,ACDDFN,ACDDFNP,ACDTRIB,ACDP,ACDSEX,ACDAGE,ACDINVR,ACDCOMC,ACDCONT,ACDPROBP,ACDINVSH,ACDPLAA,ACDPLAA1,ACDPLAR,ACDPLAR1,ACDINVPP,ACDINVCT,ACDINVTD,ACDINVTC,ACDPROVA
+8 SET ACDN0=^ACDINTV(ACDDA,0)
+9 SET ACDPG=$PIECE(ACDN0,U,17)
SET ACDPG=$PIECE(^ACDF5PI(ACDPG,0),U)
SET ACDPG=$PIECE(^AUTTLOC(ACDPG,0),U)
SET ACDAUF=$PIECE(^(0),U,10)
SET ACDPG=$PIECE(^DIC(4,ACDPG,0),U)
+10 SET Y=$PIECE(ACDN0,U)
SET ACDCLIV=$$DD^ACDFUNC(Y)
+11 SET (ACDDFN,ACDDFNP)=$PIECE(ACDN0,U,2)
IF 'ACDDFN
SET ACDDFN="NONE"
SET ACDDFNP=0
SET ACDDFN=$SELECT($DATA(^DPT(ACDDFN,0)):$PIECE(^(0),U),1:"NONE")
+12 IF $GET(ACDDFNP)'=0
SET ACDDFNP=1_ACDAUF_ACDDFNP
+13 SET ACDTRIB=$PIECE(ACDN0,U,3)
IF ACDTRIB=""
SET ACDTRIB="UNKNOWN"
+14 SET ACDP(3)=$PIECE(ACDN0,U,4)
SET ACDP(2)=3
SET ACDP(1)=9002173.5
SET ACDSEX=$$SETS^ACDFUNC(.ACDP)
+15 SET ACDAGE=$PIECE(ACDN0,U,5)
+16 SET ACDINVR=$PIECE(ACDN0,U,6)
+17 ;
+18 ; not really in CDMIS COMPONENT file
SET ACDCOMC="INTERVENTIONS"
+19 SET ACDCOMCS="INT"
+20 SET ACDCOMCL="INTERVENTIONS"
+21 SET (ACDCOMT,ACDP(3))=$PIECE(ACDN0,U,7)
SET ACDP(1)=9002173.5
SET ACDP(2)=17
SET ACDCOMTL=$$SETS^ACDFUNC(.ACDP)
+22 SET ACDPROBP=$PIECE(ACDN0,U,8)
IF 'ACDPROBP
SET ACDPROBP="NONE"
SET ACDPROBP=$SELECT($DATA(^ACDPROB(ACDPROBP,0)):$PIECE(^(0),U),1:"NONE")
+23 SET ACDINVSH=$PIECE(ACDN0,U,9)
+24 SET ACDPLAR=$PIECE(ACDN0,U,10)
IF 'ACDPLAR
SET ACDPLAR="NONE"
SET ACDPLAR=$SELECT($DATA(^ACDCOMP(ACDPLAR,0)):$PIECE(^(0),U),1:"NONE")
+25 SET ACDP(3)=$PIECE(ACDN0,U,19)
SET ACDP(1)=9002173.5
SET ACDP(2)=21
SET ACDPLAR1=$$SETS^ACDFUNC(.ACDP)
+26 SET ACDPLAA=$PIECE(ACDN0,U,11)
IF 'ACDPLAA
SET ACDPLAA="NONE"
SET ACDPLAA=$SELECT($DATA(^ACDCOMP(ACDPLAA,0)):$PIECE(^(0),U),1:"NONE")
+27 SET ACDP(3)=$PIECE(ACDN0,U,18)
SET ACDP(1)=9002173.5
SET ACDP(2)=20
SET ACDPLAA1=$$SETS^ACDFUNC(.ACDP)
+28 SET ACDDIF=$PIECE(ACDN0,U,12)
IF 'ACDDIF
SET ACDDIF="NONE"
SET ACDDIF=$SELECT($DATA(^ACDPLEX(ACDDIF,0)):$PIECE(^(0),U),1:"NONE")
+29 SET ACDINVPP=$PIECE(ACDN0,U,13)
+30 SET ACDINVCT=$PIECE(ACDN0,U,14)
+31 SET ACDINVTD=$PIECE(ACDN0,U,15)
+32 SET ACDP(3)=$PIECE(ACDN0,U,16)
SET ACDP(2)=18
SET ACDP(1)=9002173.5
SET ACDINVTC=$$SETS^ACDFUNC(.ACDP)
+33 IF $DATA(^ACDINTV(ACDDA,1))
FOR ACDAE=0:0
SET ACDAE=$ORDER(^ACDINTV(ACDDA,1,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))=""
+34 ; not really a contact type
SET ACDCONT="INTERVENTIONS"
+35 SET ACDCONTL="INTERVENTIONS"
+36 SET ACDSTATE=$PIECE(ACDN0,U,20)
IF ACDSTATE=""
SET ACDSTATE="UNKNOWN"
+37 SET ACDP(3)=$PIECE(ACDN0,U,23)
SET ACDP1(1)=9002173.5
SET ACDP(2)=25
SET ACDVET=$$SETS^ACDFUNC(.ACDP)
+38 ;I $D(^ACDINTV(ACDDA,2)) F ACDAE=0:0 S ACDAE=$O(^ACDINTV(ACDDA,2,ACDAE)) Q:'ACDAE I $D(^(ACDAE,0)) S ACDPTP=$P(^(0),U) S:'$D(^DIC(16,ACDPTP,0)) ACDPTP="XX" I ACDPTP'="XX" S ACDPROVA($P(^DIC(16,ACDPTP,0),U))=""
+39 IF $DATA(^ACDINTV(ACDDA,2))
FOR ACDAE=0:0
SET ACDAE=$ORDER(^ACDINTV(ACDDA,2,ACDAE))
IF 'ACDAE
QUIT
IF $DATA(^(ACDAE,0))
SET ACDPTP=$PIECE(^(0),U)
IF '$DATA(^VA(200,ACDPTP,0))
SET ACDPTP="XX"
IF ACDPTP'="XX"
SET ACDPROVA($PIECE(^VA(200,ACDPTP,0),U))=""
+40 QUIT
