APCLCH2S ; IHS/CMI/LAB - community health profile print ;
;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
;
;cmi/anch/maw 9/10/2007 code set versioning in IL, IS ,IT
;
INPT ;EP
PRINT ;
D HEAD^APCLCH2P Q:$D(APCLQUIT)
IDX ;
S APCLTYPE="DX"
D IDXSUB
IL ;
K APCLL S (APCLX,C)=0 F S APCLX=$O(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLLFAC,"INDXC",APCLX)) Q:APCLX=""!(C>14) D
.S APCLY=0 F S APCLY=$O(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLLFAC,"INDXC",APCLX,APCLY)) Q:APCLY'=+APCLY D
..;S C=C+1,APCLL(C)=$E($P(^ICD9(APCLY,0),U,3),1,20)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLLFAC,"INDXC",APCLX,APCLY)_"^"_$P(^ICD9(APCLY,0),U) ;cmi/anch/maw 9/10/2007 orig line
..S C=C+1,APCLL(C)=$E($P($$ICDDX^ICDEX(APCLY),U,4),1,20)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLLFAC,"INDXC",APCLX,APCLY)_"^"_$P($$ICDDX^ICDEX(APCLY),U,2) ;cmi/anch/maw 9/10/2007 csv
S M=C
IS ;
K APCLS S (APCLX,C)=0 F S APCLX=$O(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLSFAC,"INDXC",APCLX)) Q:APCLX=""!(C>14) D
.S APCLY=0 F S APCLY=$O(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLSFAC,"INDXC",APCLX,APCLY)) Q:APCLY'=+APCLY D
..;S C=C+1,APCLS(C)=$E($P(^ICD9(APCLY,0),U,3),1,20)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLSFAC,"INDXC",APCLX,APCLY)_"^"_$P(^ICD9(APCLY,0),U) ;cmi/anch/maw 9/10/2007 orig line
..S C=C+1,APCLS(C)=$E($P($$ICDDX^ICDEX(APCLY),U,4),1,20)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLSFAC,"INDXC",APCLX,APCLY)_"^"_$P($$ICDDX^ICDEX(APCLY),U,2) ;cmi/anch/maw 9/10/2007 csv
S M=C
S:C>M M=C
IT ;
K APCLT S (APCLX,C)=0 F S APCLX=$O(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLTFAC,"INDXC",APCLX)) Q:APCLX=""!(C>14) D
.S APCLY=0 F S APCLY=$O(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLTFAC,"INDXC",APCLX,APCLY)) Q:APCLY'=+APCLY D
..;S C=C+1,APCLT(C)=$E($P(^ICD9(APCLY,0),U,3),1,20)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLTFAC,"INDXC",APCLX,APCLY)_"^"_$P(^ICD9(APCLY,0),U) ;cmi/anch/maw 9/10/2007 orig line
..S C=C+1,APCLT(C)=$E($P($$ICDDX^ICDEX(APCLY),U,4),1,20)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLTFAC,"INDXC",APCLX,APCLY)_"^"_$P($$ICDDX^ICDEX(APCLY),U,2) ;cmi/anch/maw 9/10/2007 csv
S M=C
S:C>M M=C
WIDX ;write inpatient diagnoses/pov's
F APCLI=1:1:M D Q:$D(APCLQUIT)
.I $Y>(IOSL-4) D HEAD^APCLCH2P Q:$D(APCLQUIT) D IDXSUB
.W !
.I $D(APCLL(APCLI)) W ?3,$E($P(APCLL(APCLI),U),1,20),?30,"(",$P(APCLL(APCLI),U,3),")",?35,$J($P(APCLL(APCLI),U,2),6)
.I $D(APCLS(APCLI)) W ?46,$E($P(APCLS(APCLI),U),1,20),?68,"(",$P(APCLS(APCLI),U,3),")",?78,$J($P(APCLS(APCLI),U,2),6)
.I $D(APCLT(APCLI)) W ?89,$E($P(APCLT(APCLI),U),1,20),?111,"(",$P(APCLT(APCLI),U,3),")",?121,$J($P(APCLT(APCLI),U,2),6)
IDXCAT ;
S APCLTYPE="CAT"
I $Y>(IOSL-4) D HEAD^APCLCH2P Q:$D(APCLQUIT)
W !!! D IDXSUB
ILCAT ;
K APCLL S (APCLX,C)=0 F S APCLX=$O(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLLFAC,"INCATC",APCLX)) Q:APCLX=""!(C>14) D
.S APCLY=0 F S APCLY=$O(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLLFAC,"INCATC",APCLX,APCLY)) Q:APCLY'=+APCLY D
..S C=C+1,APCLL(C)=$E($P(^ICM(APCLY,0),U),1,30)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLLFAC,"INCATC",APCLX,APCLY)
S M=C
ISCAT ;
K APCLS S (APCLX,C)=0 F S APCLX=$O(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLSFAC,"INCATC",APCLX)) Q:APCLX=""!(C>14) D
.S APCLY=0 F S APCLY=$O(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLSFAC,"INCATC",APCLX,APCLY)) Q:APCLY'=+APCLY D
..S C=C+1,APCLS(C)=$E($P(^ICM(APCLY,0),U),1,30)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLSFAC,"INCATC",APCLX,APCLY)
S:C>M M=C
ITCAT ;
K APCLT S (APCLX,C)=0 F S APCLX=$O(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLTFAC,"INCATC",APCLX)) Q:APCLX=""!(C>14) D
.S APCLY=0 F S APCLY=$O(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLTFAC,"INCATC",APCLX,APCLY)) Q:APCLY'=+APCLY D
..S C=C+1,APCLT(C)=$E($P(^ICM(APCLY,0),U),1,30)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLTFAC,"INCATC",APCLX,APCLY)
S:C>M M=C
WOCAT ;write inpatient diagnoses/pov's
F APCLI=1:1:M D Q:$D(APCLQUIT)
.I $Y>(IOSL-4) D HEAD^APCLCH2P Q:$D(APCLQUIT) D IDXSUB
.W !
.I $D(APCLL(APCLI)) W ?3,$E($P(APCLL(APCLI),U),1,30),?35,$J($P(APCLL(APCLI),U,2),6)
.I $D(APCLS(APCLI)) W ?46,$E($P(APCLS(APCLI),U),1,30),?78,$J($P(APCLS(APCLI),U,2),6)
.I $D(APCLT(APCLI)) W ?89,$E($P(APCLT(APCLI),U),1,30),?121,$J($P(APCLT(APCLI),U,2),6)
Q
IDXSUB ;
S X="INPATIENT "_$S(APCLTYPE="DX":"DIAGNOSES",1:"MAJOR DIAGNOSTIC CATEGORIES") W !,?(132-$L(X)/2),X,!
W !?8,$P(^DIC(4,APCLLFAC,0),U),?51,$P(^DIC(4,APCLSFAC,0),U),?94,$P(^DIC(4,APCLTFAC,0),U),!
I APCLTYPE="DX" W !?3,"DIAGNOSIS/POV (ICD CODES)",?46,"DIAGNOSIS/POV (ICD CODES)",?89,"DIAGNOSIS/POV (ICD CODES)",!?3,"-------------",?46,"------------",?89,"------------"
I APCLTYPE="CAT" W !?3,"DIAGNOSTIC CATEGORY",?46,"DIAGNOSTIC CATEGORY",?89,"DIAGNOSTIC CATEGORY",!?3,"-------------------",?46,"-------------------",?89,"-------------------"
Q
APCLCH2S ; IHS/CMI/LAB - community health profile print ;
+1 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
+2 ;
+3 ;cmi/anch/maw 9/10/2007 code set versioning in IL, IS ,IT
+4 ;
INPT ;EP
PRINT ;
+1 DO HEAD^APCLCH2P
IF $DATA(APCLQUIT)
QUIT
IDX ;
+1 SET APCLTYPE="DX"
+2 DO IDXSUB
IL ;
+1 KILL APCLL
SET (APCLX,C)=0
FOR
SET APCLX=$ORDER(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLLFAC,"INDXC",APCLX))
IF APCLX=""!(C>14)
QUIT
Begin DoDot:1
+2 SET APCLY=0
FOR
SET APCLY=$ORDER(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLLFAC,"INDXC",APCLX,APCLY))
IF APCLY'=+APCLY
QUIT
Begin DoDot:2
+3 ;S C=C+1,APCLL(C)=$E($P(^ICD9(APCLY,0),U,3),1,20)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLLFAC,"INDXC",APCLX,APCLY)_"^"_$P(^ICD9(APCLY,0),U) ;cmi/anch/maw 9/10/2007 orig line
+4 ;cmi/anch/maw 9/10/2007 csv
SET C=C+1
SET APCLL(C)=$EXTRACT($PIECE($$ICDDX^ICDEX(APCLY),U,4),1,20)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLLFAC,"INDXC",APCLX,APCLY)_"^"_$PIECE($$ICDDX^ICDEX(APCLY),U,2)
End DoDot:2
End DoDot:1
+5 SET M=C
IS ;
+1 KILL APCLS
SET (APCLX,C)=0
FOR
SET APCLX=$ORDER(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLSFAC,"INDXC",APCLX))
IF APCLX=""!(C>14)
QUIT
Begin DoDot:1
+2 SET APCLY=0
FOR
SET APCLY=$ORDER(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLSFAC,"INDXC",APCLX,APCLY))
IF APCLY'=+APCLY
QUIT
Begin DoDot:2
+3 ;S C=C+1,APCLS(C)=$E($P(^ICD9(APCLY,0),U,3),1,20)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLSFAC,"INDXC",APCLX,APCLY)_"^"_$P(^ICD9(APCLY,0),U) ;cmi/anch/maw 9/10/2007 orig line
+4 ;cmi/anch/maw 9/10/2007 csv
SET C=C+1
SET APCLS(C)=$EXTRACT($PIECE($$ICDDX^ICDEX(APCLY),U,4),1,20)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLSFAC,"INDXC",APCLX,APCLY)_"^"_$PIECE($$ICDDX^ICDEX(APCLY),U,2)
End DoDot:2
End DoDot:1
+5 SET M=C
+6 IF C>M
SET M=C
IT ;
+1 KILL APCLT
SET (APCLX,C)=0
FOR
SET APCLX=$ORDER(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLTFAC,"INDXC",APCLX))
IF APCLX=""!(C>14)
QUIT
Begin DoDot:1
+2 SET APCLY=0
FOR
SET APCLY=$ORDER(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLTFAC,"INDXC",APCLX,APCLY))
IF APCLY'=+APCLY
QUIT
Begin DoDot:2
+3 ;S C=C+1,APCLT(C)=$E($P(^ICD9(APCLY,0),U,3),1,20)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLTFAC,"INDXC",APCLX,APCLY)_"^"_$P(^ICD9(APCLY,0),U) ;cmi/anch/maw 9/10/2007 orig line
+4 ;cmi/anch/maw 9/10/2007 csv
SET C=C+1
SET APCLT(C)=$EXTRACT($PIECE($$ICDDX^ICDEX(APCLY),U,4),1,20)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLTFAC,"INDXC",APCLX,APCLY)_"^"_$PIECE($$ICDDX^ICDEX(APCLY),U,2)
End DoDot:2
End DoDot:1
+5 SET M=C
+6 IF C>M
SET M=C
WIDX ;write inpatient diagnoses/pov's
+1 FOR APCLI=1:1:M
Begin DoDot:1
+2 IF $Y>(IOSL-4)
DO HEAD^APCLCH2P
IF $DATA(APCLQUIT)
QUIT
DO IDXSUB
+3 WRITE !
+4 IF $DATA(APCLL(APCLI))
WRITE ?3,$EXTRACT($PIECE(APCLL(APCLI),U),1,20),?30,"(",$PIECE(APCLL(APCLI),U,3),")",?35,$JUSTIFY($PIECE(APCLL(APCLI),U,2),6)
+5 IF $DATA(APCLS(APCLI))
WRITE ?46,$EXTRACT($PIECE(APCLS(APCLI),U),1,20),?68,"(",$PIECE(APCLS(APCLI),U,3),")",?78,$JUSTIFY($PIECE(APCLS(APCLI),U,2),6)
+6 IF $DATA(APCLT(APCLI))
WRITE ?89,$EXTRACT($PIECE(APCLT(APCLI),U),1,20),?111,"(",$PIECE(APCLT(APCLI),U,3),")",?121,$JUSTIFY($PIECE(APCLT(APCLI),U,2),6)
End DoDot:1
IF $DATA(APCLQUIT)
QUIT
IDXCAT ;
+1 SET APCLTYPE="CAT"
+2 IF $Y>(IOSL-4)
DO HEAD^APCLCH2P
IF $DATA(APCLQUIT)
QUIT
+3 WRITE !!!
DO IDXSUB
ILCAT ;
+1 KILL APCLL
SET (APCLX,C)=0
FOR
SET APCLX=$ORDER(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLLFAC,"INCATC",APCLX))
IF APCLX=""!(C>14)
QUIT
Begin DoDot:1
+2 SET APCLY=0
FOR
SET APCLY=$ORDER(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLLFAC,"INCATC",APCLX,APCLY))
IF APCLY'=+APCLY
QUIT
Begin DoDot:2
+3 SET C=C+1
SET APCLL(C)=$EXTRACT($PIECE(^ICM(APCLY,0),U),1,30)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLLFAC,"INCATC",APCLX,APCLY)
End DoDot:2
End DoDot:1
+4 SET M=C
ISCAT ;
+1 KILL APCLS
SET (APCLX,C)=0
FOR
SET APCLX=$ORDER(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLSFAC,"INCATC",APCLX))
IF APCLX=""!(C>14)
QUIT
Begin DoDot:1
+2 SET APCLY=0
FOR
SET APCLY=$ORDER(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLSFAC,"INCATC",APCLX,APCLY))
IF APCLY'=+APCLY
QUIT
Begin DoDot:2
+3 SET C=C+1
SET APCLS(C)=$EXTRACT($PIECE(^ICM(APCLY,0),U),1,30)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLSFAC,"INCATC",APCLX,APCLY)
End DoDot:2
End DoDot:1
+4 IF C>M
SET M=C
ITCAT ;
+1 KILL APCLT
SET (APCLX,C)=0
FOR
SET APCLX=$ORDER(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLTFAC,"INCATC",APCLX))
IF APCLX=""!(C>14)
QUIT
Begin DoDot:1
+2 SET APCLY=0
FOR
SET APCLY=$ORDER(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLTFAC,"INCATC",APCLX,APCLY))
IF APCLY'=+APCLY
QUIT
Begin DoDot:2
+3 SET C=C+1
SET APCLT(C)=$EXTRACT($PIECE(^ICM(APCLY,0),U),1,30)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLTFAC,"INCATC",APCLX,APCLY)
End DoDot:2
End DoDot:1
+4 IF C>M
SET M=C
WOCAT ;write inpatient diagnoses/pov's
+1 FOR APCLI=1:1:M
Begin DoDot:1
+2 IF $Y>(IOSL-4)
DO HEAD^APCLCH2P
IF $DATA(APCLQUIT)
QUIT
DO IDXSUB
+3 WRITE !
+4 IF $DATA(APCLL(APCLI))
WRITE ?3,$EXTRACT($PIECE(APCLL(APCLI),U),1,30),?35,$JUSTIFY($PIECE(APCLL(APCLI),U,2),6)
+5 IF $DATA(APCLS(APCLI))
WRITE ?46,$EXTRACT($PIECE(APCLS(APCLI),U),1,30),?78,$JUSTIFY($PIECE(APCLS(APCLI),U,2),6)
+6 IF $DATA(APCLT(APCLI))
WRITE ?89,$EXTRACT($PIECE(APCLT(APCLI),U),1,30),?121,$JUSTIFY($PIECE(APCLT(APCLI),U,2),6)
End DoDot:1
IF $DATA(APCLQUIT)
QUIT
+7 QUIT
IDXSUB ;
+1 SET X="INPATIENT "_$SELECT(APCLTYPE="DX":"DIAGNOSES",1:"MAJOR DIAGNOSTIC CATEGORIES")
WRITE !,?(132-$LENGTH(X)/2),X,!
+2 WRITE !?8,$PIECE(^DIC(4,APCLLFAC,0),U),?51,$PIECE(^DIC(4,APCLSFAC,0),U),?94,$PIECE(^DIC(4,APCLTFAC,0),U),!
+3 IF APCLTYPE="DX"
WRITE !?3,"DIAGNOSIS/POV (ICD CODES)",?46,"DIAGNOSIS/POV (ICD CODES)",?89,"DIAGNOSIS/POV (ICD CODES)",!?3,"-------------",?46,"------------",?89,"------------"
+4 IF APCLTYPE="CAT"
WRITE !?3,"DIAGNOSTIC CATEGORY",?46,"DIAGNOSTIC CATEGORY",?89,"DIAGNOSTIC CATEGORY",!?3,"-------------------",?46,"-------------------",?89,"-------------------"
+5 QUIT
