- 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
