- 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