AQAOPC23 ; IHS/ORDC/LJF - SUBRTN TO PRINT OCC WITH ICD ;
;;1.01;QAI MANAGEMENT;;OCT 05, 1995
;
;This rtn contains the entry point called by ^AQAOPC22. It collects
;all diagnoses and procedures for an occurrence and prints them.
;
ICDPRINT ;ENTRY POINT
; >>> SUBRTN to collect icd codes then call PRINT to print them
K AQAOPV,AQAODX,AQAOPC
;
; >> get all providers listed for occ
S (X,I)=0 F S X=$O(^AQAOCC(7,"AB",AQAON,X)) Q:X="" D
.Q:'$D(^AQAOCC(7,X,0)) S I=I+1,Y=+^(0)
.S AQAOPV(I)=$S(Y["VA(200":"I",1:"C")_+Y
.; increment count for this provider
.S ^TMP("AQAO",$J,"V",AQAOSUB,AQAOPV(I))=$G(^TMP("AQAO",$J,"V",AQAOSUB,AQAOPV(I)))+1
;
;
; >> get all dx listed for occ
S (X,I)=0 F S X=$O(^AQAOCC(8,"AB",AQAON,X)) Q:X="" D
.Q:'$D(^AQAOCC(8,X,0)) S Y=+^(0) ;pointer to icd9 file
.S I=I+1
.I $D(AQAODLM) S AQAODX(I)=$P(^ICD9(Y,0),U)_AQAODLM_$E($P(^(0),U,3),1,30)
.E S AQAODX(I)=$P(^ICD9(Y,0),U)_": "_$E($P(^(0),U,3),1,30)
.; increment count for this dx
.S ^TMP("AQAO",$J,"D",AQAOSUB,AQAODX(I))=$G(^TMP("AQAO",$J,"D",AQAOSUB,AQAODX(I)))+1
;
;
; >> get all procedures listed for occ
S (X,I)=0 F S X=$O(^AQAOCC(9,"AB",AQAON,X)) Q:X="" D
.Q:'$D(^AQAOCC(9,X,0)) S Y=+^(0) ;pointer to icd0 file
.S I=I+1
.I $D(AQAODLM) S AQAOPC(I)=$P(^ICD0(Y,0),U)_AQAODLM_$E($P(^(0),U,4),1,30)
.E S AQAOPC(I)=$P(^ICD0(Y,0),U)_": "_$E($P(^(0),U,4),1,30)
.; increment count for this procedure
.S ^TMP("AQAO",$J,"P",AQAOSUB,AQAOPC(I))=$G(^TMP("AQAO",$J,"P",AQAOSUB,AQAOPC(I)))+1
;
;
; >> print all prov, dx, proc with same subscripts on same line
Q:AQAOTYPE="S" ;summary page only, no print
F I=1:1 Q:'$D(AQAOPV(I))&'$D(AQAODX(I))&'$D(AQAOPC(I)) D
.I $D(AQAODLM) D
..I I=1 W AQAODLM,$G(AQAOPV(I)),AQAODLM,$G(AQAODX(I)),AQAODLM,$G(AQAOPC(I)),!
..E D
...F I=1:1:7 W AQAODLM
...W $G(AQAOPV(I)),AQAODLM,$G(AQAODX(I)),AQAODLM,$G(AQAOPC(I)),!
.E W ?45,$G(AQAOPV(I)),?52,$G(AQAODX(I)),?92,$G(AQAOPC(I)),!
Q
AQAOPC23 ; IHS/ORDC/LJF - SUBRTN TO PRINT OCC WITH ICD ;
+1 ;;1.01;QAI MANAGEMENT;;OCT 05, 1995
+2 ;
+3 ;This rtn contains the entry point called by ^AQAOPC22. It collects
+4 ;all diagnoses and procedures for an occurrence and prints them.
+5 ;
ICDPRINT ;ENTRY POINT
+1 ; >>> SUBRTN to collect icd codes then call PRINT to print them
+2 KILL AQAOPV,AQAODX,AQAOPC
+3 ;
+4 ; >> get all providers listed for occ
+5 SET (X,I)=0
FOR
SET X=$ORDER(^AQAOCC(7,"AB",AQAON,X))
IF X=""
QUIT
Begin DoDot:1
+6 IF '$DATA(^AQAOCC(7,X,0))
QUIT
SET I=I+1
SET Y=+^(0)
+7 SET AQAOPV(I)=$SELECT(Y["VA(200":"I",1:"C")_+Y
+8 ; increment count for this provider
+9 SET ^TMP("AQAO",$JOB,"V",AQAOSUB,AQAOPV(I))=$GET(^TMP("AQAO",$JOB,"V",AQAOSUB,AQAOPV(I)))+1
End DoDot:1
+10 ;
+11 ;
+12 ; >> get all dx listed for occ
+13 SET (X,I)=0
FOR
SET X=$ORDER(^AQAOCC(8,"AB",AQAON,X))
IF X=""
QUIT
Begin DoDot:1
+14 ;pointer to icd9 file
IF '$DATA(^AQAOCC(8,X,0))
QUIT
SET Y=+^(0)
+15 SET I=I+1
+16 IF $DATA(AQAODLM)
SET AQAODX(I)=$PIECE(^ICD9(Y,0),U)_AQAODLM_$EXTRACT($PIECE(^(0),U,3),1,30)
+17 IF '$TEST
SET AQAODX(I)=$PIECE(^ICD9(Y,0),U)_": "_$EXTRACT($PIECE(^(0),U,3),1,30)
+18 ; increment count for this dx
+19 SET ^TMP("AQAO",$JOB,"D",AQAOSUB,AQAODX(I))=$GET(^TMP("AQAO",$JOB,"D",AQAOSUB,AQAODX(I)))+1
End DoDot:1
+20 ;
+21 ;
+22 ; >> get all procedures listed for occ
+23 SET (X,I)=0
FOR
SET X=$ORDER(^AQAOCC(9,"AB",AQAON,X))
IF X=""
QUIT
Begin DoDot:1
+24 ;pointer to icd0 file
IF '$DATA(^AQAOCC(9,X,0))
QUIT
SET Y=+^(0)
+25 SET I=I+1
+26 IF $DATA(AQAODLM)
SET AQAOPC(I)=$PIECE(^ICD0(Y,0),U)_AQAODLM_$EXTRACT($PIECE(^(0),U,4),1,30)
+27 IF '$TEST
SET AQAOPC(I)=$PIECE(^ICD0(Y,0),U)_": "_$EXTRACT($PIECE(^(0),U,4),1,30)
+28 ; increment count for this procedure
+29 SET ^TMP("AQAO",$JOB,"P",AQAOSUB,AQAOPC(I))=$GET(^TMP("AQAO",$JOB,"P",AQAOSUB,AQAOPC(I)))+1
End DoDot:1
+30 ;
+31 ;
+32 ; >> print all prov, dx, proc with same subscripts on same line
+33 ;summary page only, no print
IF AQAOTYPE="S"
QUIT
+34 FOR I=1:1
IF '$DATA(AQAOPV(I))&'$DATA(AQAODX(I))&'$DATA(AQAOPC(I))
QUIT
Begin DoDot:1
+35 IF $DATA(AQAODLM)
Begin DoDot:2
+36 IF I=1
WRITE AQAODLM,$GET(AQAOPV(I)),AQAODLM,$GET(AQAODX(I)),AQAODLM,$GET(AQAOPC(I)),!
+37 IF '$TEST
Begin DoDot:3
+38 FOR I=1:1:7
WRITE AQAODLM
+39 WRITE $GET(AQAOPV(I)),AQAODLM,$GET(AQAODX(I)),AQAODLM,$GET(AQAOPC(I)),!
End DoDot:3
End DoDot:2
+40 IF '$TEST
WRITE ?45,$GET(AQAOPV(I)),?52,$GET(AQAODX(I)),?92,$GET(AQAOPC(I)),!
End DoDot:1
+41 QUIT
