- 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
