- 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
