ACDPCCL3 ;IHS/ADC/EDE/KML - PCC LINK;
;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
;
;
SETIIF ; SET IIF VARIABLES
S ACDQ=1
S ACDIIF=$O(ACDPCCL(ACDDFNP,ACDVIEN,"IIF",0))
I 'ACDIIF D ERROR^ACDPCCL("No IIF entry specified for visit",5) Q
I '$D(^ACDIIF(ACDIIF,0)) D ERROR^ACDPCCL("Specified IIF entry doesn't exist",5) Q
S ACDEV("IIF IEN")=ACDIIF
S X=^ACDIIF(ACDIIF,0)
S ACDEV("TIME")=$P(X,U,6)*60
I '+X D ERROR^ACDPCCL("No primary problem in specified IIF entry",5) Q
S W=$P(^ACDPROB(+X,0),U,3)
I W="" D ERROR^ACDPCCL("No ICD9 code for primary problem",5) Q
S W=W_":"_$P(^ICD9(W,0),U)
S Z=$S($P(^ACDPROB(+X,0),U,2)="55":0,1:1) I 'Z,$P(X,U,2)="" S Z=1
S ACDEV("POV",2)=W_":CHEMICAL DEPENDENCY-"_$S(Z:$P(^ACDPROB(+X,0),U),1:$P(X,U,2))
S Y=0 F C=3:1 S Y=$O(^ACDIIF(ACDIIF,3,Y)) Q:'Y I $D(^ACDIIF(ACDIIF,3,Y,0)) S X=^(0) D
. I '+X D ERROR^ACDPCCL("No problem in OTHER PROBLEMS multiple entry",5) Q
. S W=$P(^ACDPROB(+X,0),U,3)
. Q:W="" ; no ICD9 code
. S W=W_":"_$P(^ICD9(W,0),U)
. S Z=$S($P(^ACDPROB(+X,0),U,2)="55":0,1:1) I 'Z,$P(X,U,2)="" S Z=1
. S ACDEV("POV",C)=W_":CHEMICAL DEPENDENCY-"_$S(Z:$P(^ACDPROB(+X,0),U),1:$P(X,U,2))
. Q
S ACDQ=0
D EOJ
Q
;
SETTDC ; SET TDC VARIABLES
S ACDQ=1
S ACDTDC=$O(ACDPCCL(ACDDFNP,ACDVIEN,"TDC",0))
I 'ACDTDC D ERROR^ACDPCCL("No TDC entry for visit",5) Q
I '$D(^ACDTDC(ACDTDC,0)) D ERROR^ACDPCCL("Specified TDC entry doesn't exist",5) Q
S ACDEV("TDC IEN")=ACDTDC
S X=^ACDTDC(ACDTDC,0)
S ACDEV("TIME")=$P(X,U,29)*60
S W=+$P(X,U,27)
I 'W D ERROR^ACDPCCL("No primary problem in specified TDC entry",5) Q
S W=$P(^ACDPROB(W,0),U,3)
Q:W="" ; no ICD9 code
S W=W_":"_$P(^ICD9(W,0),U)
S Z=$S($P(^ACDPROB(+$P(X,U,27),0),U,2)="55":0,1:1) I 'Z,$P(X,U,28)="" S Z=1
S ACDEV("POV",2)=W_":CHEMICAL DEPENDENCY-"_$S(Z:$P(^ACDPROB(+$P(X,U,27),0),U),1:$P(X,U,28))
S Y=0 F C=3:1 S Y=$O(^ACDTDC(ACDTDC,3,Y)) Q:'Y I $D(^ACDTDC(ACDTDC,3,Y,0)) S X=^(0) D
. I '+X D ERROR^ACDPCCL("No problem in OTHER PROBLEMS multiple entry",5) Q
. S W=$P(^ACDPROB(+X,0),U,3)
. Q:W="" ; no ICD9 code
. S W=W_":"_$P(^ICD9(W,0),U)
. S Z=$S($P(^ACDPROB(+X,0),U,2)="55":0,1:1) I 'Z,$P(X,U,2)="" S Z=1
. S ACDEV("POV",C)=W_":CHEMICAL DEPENDENCY-"_$S(Z:$P(^ACDPROB(+X,0),U),1:$P(X,U,2))
. Q
S ACDQ=0
D EOJ
Q
;
SETCS ; SET CS VARIABLES
S ACDQ=1
S ACDCS=$O(ACDPCCL(ACDDFNP,ACDVIEN,"CS",0))
I 'ACDCS D ERROR^ACDPCCL("No CS entry specified for visit",5) Q
S X="V65.4",W=$O(^ICD9("AB",X,0))
I 'W D ERROR^ACDPCCL("Cannot find ICD9 code V65.4 - notify programmer",5) Q
S Y="V65.42",Y=$O(^ICD9("AB",Y,0)) S:Y W=Y,X="V65.42"
S ACDEV("POV",1)=W_":"_X_":CONSULTING ON SUBSTANCE USE & ABUSE"
S (ACDC,ACDCS)=0 F S ACDCS=$O(ACDPCCL(ACDDFNP,ACDVIEN,"CS",ACDCS)) Q:'ACDCS D SETCS2
S ACDQ=0
D EOJ
Q
;
SETCS2 ;
S ACDQ=1
I '$D(^ACDCS(ACDCS,0)) D ERROR^ACDPCCL("Specified CS entry doesn't exist",5) Q
S X2=+^ACDCS(ACDCS,0)-1,X1=ACDEV("V DATE") D C^%DTC S ACDCSDTE=X
S ACDX=^ACDCS(ACDCS,0)
S W=+$P(ACDX,U,2)
I 'W D ERROR^ACDPCCL("No client service in specified CS entry",5) Q
S ACDNARR=$P(^ACDSERV(W,0),U)
S Y=$P(^ACDSERV(W,0),U,4)
;S W=$P(^ACDSERV(W,0),U,4)
;Q:W="" ; no ICD0 code
;S W=W_":"_$P(^ICD0(W,0),U)
S W=$P(^ACDSERV(W,0),U,5)
Q:W="" ; no CPT code
S W=W_":"_$P(^ICPT(W,0),U) ; cpt code
S:Y W=W_"/"_$P(^ICD0(Y,0),U) ; icd0 code
S (ACDCSLOC,ACDLOC)=$P(ACDX,U,3)
I ACDFPCC D Q:ACDQ S ACDQ=1,ACDLOC=ACDLOCPC,ACDEV("PROC",ACDCSDTE,ACDLOC,"PCC LOC")=ACDLOCPC ; use PCC location if available
. S ACDQ=0
. I $P(ACDX,U,6) S ACDLOCPC=$P(ACDX,U,6) Q
. S ACDLOCPC=$P(^ACDLOT(+$P(ACDX,U,3),0),U,4)
. I 'ACDLOCPC D ERROR^ACDPCCL("No PCC LOCATION for CDMIS LOCATION entry",5) S ACDQ=1 Q
. Q
S ACDEV("PROC",ACDCSDTE,ACDLOC,"CS LOC")=ACDCSLOC
S ACDC=ACDC+1
S ACDEV("PROC",ACDCSDTE,ACDLOC,ACDC,"CS IEN")=ACDCS
S ACDEV("PROC",ACDCSDTE,ACDLOC,ACDC,"NARR")=W_":CHEMICAL DEPENDENCY-"_ACDNARR
S ACDEV("PROC",ACDCSDTE,ACDLOC,ACDC,"TIME")=$P(ACDX,U,4)*60
S Y=0 F S Y=$O(^ACDCS(ACDCS,1,Y)) Q:'Y I $D(^ACDCS(ACDCS,1,Y,0)) S X=+^(0),ACDEV("PROC",ACDCSDTE,ACDLOC,ACDC,"PROV",X)="",ACDEV("PROC",ACDCSDTE,ACDLOC,"PROV",X)=""
S ACDQ=0
Q
;
EOJ ;
K ACDC,ACDCS,ACDCSDTE,ACDCSLOC,ACDIIF,ACDLOC,ACDLOCPC,ACDNARR,ACDTDC,ACDX
Q
ACDPCCL3 ;IHS/ADC/EDE/KML - PCC LINK;
+1 ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
+2 ;
+3 ;
SETIIF ; SET IIF VARIABLES
+1 SET ACDQ=1
+2 SET ACDIIF=$ORDER(ACDPCCL(ACDDFNP,ACDVIEN,"IIF",0))
+3 IF 'ACDIIF
DO ERROR^ACDPCCL("No IIF entry specified for visit",5)
QUIT
+4 IF '$DATA(^ACDIIF(ACDIIF,0))
DO ERROR^ACDPCCL("Specified IIF entry doesn't exist",5)
QUIT
+5 SET ACDEV("IIF IEN")=ACDIIF
+6 SET X=^ACDIIF(ACDIIF,0)
+7 SET ACDEV("TIME")=$PIECE(X,U,6)*60
+8 IF '+X
DO ERROR^ACDPCCL("No primary problem in specified IIF entry",5)
QUIT
+9 SET W=$PIECE(^ACDPROB(+X,0),U,3)
+10 IF W=""
DO ERROR^ACDPCCL("No ICD9 code for primary problem",5)
QUIT
+11 SET W=W_":"_$PIECE(^ICD9(W,0),U)
+12 SET Z=$SELECT($PIECE(^ACDPROB(+X,0),U,2)="55":0,1:1)
IF 'Z
IF $PIECE(X,U,2)=""
SET Z=1
+13 SET ACDEV("POV",2)=W_":CHEMICAL DEPENDENCY-"_$SELECT(Z:$PIECE(^ACDPROB(+X,0),U),1:$PIECE(X,U,2))
+14 SET Y=0
FOR C=3:1
SET Y=$ORDER(^ACDIIF(ACDIIF,3,Y))
IF 'Y
QUIT
IF $DATA(^ACDIIF(ACDIIF,3,Y,0))
SET X=^(0)
Begin DoDot:1
+15 IF '+X
DO ERROR^ACDPCCL("No problem in OTHER PROBLEMS multiple entry",5)
QUIT
+16 SET W=$PIECE(^ACDPROB(+X,0),U,3)
+17 ; no ICD9 code
IF W=""
QUIT
+18 SET W=W_":"_$PIECE(^ICD9(W,0),U)
+19 SET Z=$SELECT($PIECE(^ACDPROB(+X,0),U,2)="55":0,1:1)
IF 'Z
IF $PIECE(X,U,2)=""
SET Z=1
+20 SET ACDEV("POV",C)=W_":CHEMICAL DEPENDENCY-"_$SELECT(Z:$PIECE(^ACDPROB(+X,0),U),1:$PIECE(X,U,2))
+21 QUIT
End DoDot:1
+22 SET ACDQ=0
+23 DO EOJ
+24 QUIT
+25 ;
SETTDC ; SET TDC VARIABLES
+1 SET ACDQ=1
+2 SET ACDTDC=$ORDER(ACDPCCL(ACDDFNP,ACDVIEN,"TDC",0))
+3 IF 'ACDTDC
DO ERROR^ACDPCCL("No TDC entry for visit",5)
QUIT
+4 IF '$DATA(^ACDTDC(ACDTDC,0))
DO ERROR^ACDPCCL("Specified TDC entry doesn't exist",5)
QUIT
+5 SET ACDEV("TDC IEN")=ACDTDC
+6 SET X=^ACDTDC(ACDTDC,0)
+7 SET ACDEV("TIME")=$PIECE(X,U,29)*60
+8 SET W=+$PIECE(X,U,27)
+9 IF 'W
DO ERROR^ACDPCCL("No primary problem in specified TDC entry",5)
QUIT
+10 SET W=$PIECE(^ACDPROB(W,0),U,3)
+11 ; no ICD9 code
IF W=""
QUIT
+12 SET W=W_":"_$PIECE(^ICD9(W,0),U)
+13 SET Z=$SELECT($PIECE(^ACDPROB(+$PIECE(X,U,27),0),U,2)="55":0,1:1)
IF 'Z
IF $PIECE(X,U,28)=""
SET Z=1
+14 SET ACDEV("POV",2)=W_":CHEMICAL DEPENDENCY-"_$SELECT(Z:$PIECE(^ACDPROB(+$PIECE(X,U,27),0),U),1:$PIECE(X,U,28))
+15 SET Y=0
FOR C=3:1
SET Y=$ORDER(^ACDTDC(ACDTDC,3,Y))
IF 'Y
QUIT
IF $DATA(^ACDTDC(ACDTDC,3,Y,0))
SET X=^(0)
Begin DoDot:1
+16 IF '+X
DO ERROR^ACDPCCL("No problem in OTHER PROBLEMS multiple entry",5)
QUIT
+17 SET W=$PIECE(^ACDPROB(+X,0),U,3)
+18 ; no ICD9 code
IF W=""
QUIT
+19 SET W=W_":"_$PIECE(^ICD9(W,0),U)
+20 SET Z=$SELECT($PIECE(^ACDPROB(+X,0),U,2)="55":0,1:1)
IF 'Z
IF $PIECE(X,U,2)=""
SET Z=1
+21 SET ACDEV("POV",C)=W_":CHEMICAL DEPENDENCY-"_$SELECT(Z:$PIECE(^ACDPROB(+X,0),U),1:$PIECE(X,U,2))
+22 QUIT
End DoDot:1
+23 SET ACDQ=0
+24 DO EOJ
+25 QUIT
+26 ;
SETCS ; SET CS VARIABLES
+1 SET ACDQ=1
+2 SET ACDCS=$ORDER(ACDPCCL(ACDDFNP,ACDVIEN,"CS",0))
+3 IF 'ACDCS
DO ERROR^ACDPCCL("No CS entry specified for visit",5)
QUIT
+4 SET X="V65.4"
SET W=$ORDER(^ICD9("AB",X,0))
+5 IF 'W
DO ERROR^ACDPCCL("Cannot find ICD9 code V65.4 - notify programmer",5)
QUIT
+6 SET Y="V65.42"
SET Y=$ORDER(^ICD9("AB",Y,0))
IF Y
SET W=Y
SET X="V65.42"
+7 SET ACDEV("POV",1)=W_":"_X_":CONSULTING ON SUBSTANCE USE & ABUSE"
+8 SET (ACDC,ACDCS)=0
FOR
SET ACDCS=$ORDER(ACDPCCL(ACDDFNP,ACDVIEN,"CS",ACDCS))
IF 'ACDCS
QUIT
DO SETCS2
+9 SET ACDQ=0
+10 DO EOJ
+11 QUIT
+12 ;
SETCS2 ;
+1 SET ACDQ=1
+2 IF '$DATA(^ACDCS(ACDCS,0))
DO ERROR^ACDPCCL("Specified CS entry doesn't exist",5)
QUIT
+3 SET X2=+^ACDCS(ACDCS,0)-1
SET X1=ACDEV("V DATE")
DO C^%DTC
SET ACDCSDTE=X
+4 SET ACDX=^ACDCS(ACDCS,0)
+5 SET W=+$PIECE(ACDX,U,2)
+6 IF 'W
DO ERROR^ACDPCCL("No client service in specified CS entry",5)
QUIT
+7 SET ACDNARR=$PIECE(^ACDSERV(W,0),U)
+8 SET Y=$PIECE(^ACDSERV(W,0),U,4)
+9 ;S W=$P(^ACDSERV(W,0),U,4)
+10 ;Q:W="" ; no ICD0 code
+11 ;S W=W_":"_$P(^ICD0(W,0),U)
+12 SET W=$PIECE(^ACDSERV(W,0),U,5)
+13 ; no CPT code
IF W=""
QUIT
+14 ; cpt code
SET W=W_":"_$PIECE(^ICPT(W,0),U)
+15 ; icd0 code
IF Y
SET W=W_"/"_$PIECE(^ICD0(Y,0),U)
+16 SET (ACDCSLOC,ACDLOC)=$PIECE(ACDX,U,3)
+17 ; use PCC location if available
IF ACDFPCC
Begin DoDot:1
+18 SET ACDQ=0
+19 IF $PIECE(ACDX,U,6)
SET ACDLOCPC=$PIECE(ACDX,U,6)
QUIT
+20 SET ACDLOCPC=$PIECE(^ACDLOT(+$PIECE(ACDX,U,3),0),U,4)
+21 IF 'ACDLOCPC
DO ERROR^ACDPCCL("No PCC LOCATION for CDMIS LOCATION entry",5)
SET ACDQ=1
QUIT
+22 QUIT
End DoDot:1
IF ACDQ
QUIT
SET ACDQ=1
SET ACDLOC=ACDLOCPC
SET ACDEV("PROC",ACDCSDTE,ACDLOC,"PCC LOC")=ACDLOCPC
+23 SET ACDEV("PROC",ACDCSDTE,ACDLOC,"CS LOC")=ACDCSLOC
+24 SET ACDC=ACDC+1
+25 SET ACDEV("PROC",ACDCSDTE,ACDLOC,ACDC,"CS IEN")=ACDCS
+26 SET ACDEV("PROC",ACDCSDTE,ACDLOC,ACDC,"NARR")=W_":CHEMICAL DEPENDENCY-"_ACDNARR
+27 SET ACDEV("PROC",ACDCSDTE,ACDLOC,ACDC,"TIME")=$PIECE(ACDX,U,4)*60
+28 SET Y=0
FOR
SET Y=$ORDER(^ACDCS(ACDCS,1,Y))
IF 'Y
QUIT
IF $DATA(^ACDCS(ACDCS,1,Y,0))
SET X=+^(0)
SET ACDEV("PROC",ACDCSDTE,ACDLOC,ACDC,"PROV",X)=""
SET ACDEV("PROC",ACDCSDTE,ACDLOC,"PROV",X)=""
+29 SET ACDQ=0
+30 QUIT
+31 ;
EOJ ;
+1 KILL ACDC,ACDCS,ACDCSDTE,ACDCSLOC,ACDIIF,ACDLOC,ACDLOCPC,ACDNARR,ACDTDC,ACDX
+2 QUIT
