AQAOPC82 ; IHS/ORDC/LJF - PROVIDER PROFILE CALC ;
;;1.01;QAI MANAGEMENT;;OCT 05, 1995
;
;This rtn contains the code to find all occ activity for a provider
;in the occurrence files for a date range.
;
K ^TMP("AQAOPC8",$J) K ^TMP("AQAOPC8A",$J) K ^TMP("AQAOPC8B",$J)
;
LOOP ; >> loop thru qi occ provider file for provider
S AQAOX=0
F S AQAOX=$O(^AQAOCC(7,"B",AQAOPROV,AQAOX)) Q:AQAOX="" D
.Q:'$D(^AQAOCC(7,AQAOX,0)) S AQAOS=^(0) ;qi occ prv data
.S AQAOIFN=$P(AQAOS,U,2),AQAOTYP=$P(AQAOS,U,5),AQAOAP=$P(AQAOS,U,6)
.S:AQAOAP]"" AQAOAP="*" ;attributed action
.S AQAOLV=$P(AQAOS,U,7) S:AQAOLV]"" AQAOLV=$P(^AQAO1(3,AQAOLV,0),U)
.S AQAOLV=$E(AQAOLV_" ",1,4),AQAOTYP=$E(AQAOTYP_" ",1,4)
.Q:$P($G(^AQAOC(AQAOIFN,1)),U)'=1 ;occ not closed
.Q:$$EXCEP^AQAOLKP(AQAOIFN)
.Q:'$D(^AQAOC(AQAOIFN,0)) S AQAOS=^(0),AQAOCID=$P(AQAOS,U) ;case#
.S AQAOIND=$P(AQAOS,U,8) ;indicator ifn
.I '$D(AQAOMSF(0)) Q:'$D(AQAOMSF(AQAOIND)) ;ind not in list
.S AQAODT=$P(AQAOS,U,4) Q:AQAODT<AQAOBD Q:AQAODT>AQAOED ;date chk
.;
.; set variables for ^TMP nodes
.S AQAOM=$S(AQAOMSF=1:10,$P(^AQAO(2,AQAOIND,1),U,3)]"":$P(^(1),U,3),1:10)
.;S AQAOM=$P(^AQAO(2,AQAOIND,1),U,3) ;msf for ind
.;S:AQAOM="" AQAOM=10
.S AQAOIND=$P(^AQAO(2,AQAOIND,0),U)_U_AQAOIND ;ind # & name
.Q:'$D(^AQAOC(AQAOIFN,"FINAL")) S S=^("FINAL") ;no close data
.S X=$P(S,U,4),AQAOF=$S(X="":"??",1:$P(^AQAO(8,X,0),U,2)) ;find
.S X=$P(S,U,6),AQAOA=$S(X="":"??",1:$P(^AQAO(6,X,0),U,2)) ;action
.S X=$P(S,U,3),AQAOP=$S(X="":" ",1:$P(^AQAO1(3,X,0),U)) ;potential
.S X=$P(S,U,7),AQAOO=$S(X="":" ",1:$P(^AQAO1(3,X,0),U)) ;outcome
.S X=$P(S,U,8),AQAOU=$S(X="":" ",1:$P(^AQAO1(3,X,0),U)) ;ultimate
.;
.S AQAOF=$E(AQAOF_" ",1,4),AQAOA=$E(AQAOA_AQAOAP_" ",1,4) ;$L = 4
.S Z="/"
.S X=AQAOCID_U_AQAOF_Z_AQAOA_Z_AQAOTYP_Z_AQAOLV_Z_Z_AQAOP_Z_AQAOO_Z_AQAOU
.S ^TMP("AQAOPC8",$J,AQAOM,AQAOIND,AQAODT,AQAOIFN)=X
.;
.; increment counts
.S X=AQAOF_Z_AQAOA_Z_AQAOTYP_Z_AQAOLV
.S ^TMP("AQAOPC8A",$J,AQAOIND,X)=$G(^TMP("AQAOPC8A",$J,AQAOIND,X))+1
.S X=AQAOP_Z_AQAOO_Z_AQAOU
.S ^TMP("AQAOPC8B",$J,AQAOIND,X)=$G(^TMP("AQAOPC8B",$J,AQAOIND,X))+1
;
;
NEXT ; >> go to print rtn
G ^AQAOPC83
AQAOPC82 ; IHS/ORDC/LJF - PROVIDER PROFILE CALC ;
+1 ;;1.01;QAI MANAGEMENT;;OCT 05, 1995
+2 ;
+3 ;This rtn contains the code to find all occ activity for a provider
+4 ;in the occurrence files for a date range.
+5 ;
+6 KILL ^TMP("AQAOPC8",$JOB)
KILL ^TMP("AQAOPC8A",$JOB)
KILL ^TMP("AQAOPC8B",$JOB)
+7 ;
LOOP ; >> loop thru qi occ provider file for provider
+1 SET AQAOX=0
+2 FOR
SET AQAOX=$ORDER(^AQAOCC(7,"B",AQAOPROV,AQAOX))
IF AQAOX=""
QUIT
Begin DoDot:1
+3 ;qi occ prv data
IF '$DATA(^AQAOCC(7,AQAOX,0))
QUIT
SET AQAOS=^(0)
+4 SET AQAOIFN=$PIECE(AQAOS,U,2)
SET AQAOTYP=$PIECE(AQAOS,U,5)
SET AQAOAP=$PIECE(AQAOS,U,6)
+5 ;attributed action
IF AQAOAP]""
SET AQAOAP="*"
+6 SET AQAOLV=$PIECE(AQAOS,U,7)
IF AQAOLV]""
SET AQAOLV=$PIECE(^AQAO1(3,AQAOLV,0),U)
+7 SET AQAOLV=$EXTRACT(AQAOLV_" ",1,4)
SET AQAOTYP=$EXTRACT(AQAOTYP_" ",1,4)
+8 ;occ not closed
IF $PIECE($GET(^AQAOC(AQAOIFN,1)),U)'=1
QUIT
+9 IF $$EXCEP^AQAOLKP(AQAOIFN)
QUIT
+10 ;case#
IF '$DATA(^AQAOC(AQAOIFN,0))
QUIT
SET AQAOS=^(0)
SET AQAOCID=$PIECE(AQAOS,U)
+11 ;indicator ifn
SET AQAOIND=$PIECE(AQAOS,U,8)
+12 ;ind not in list
IF '$DATA(AQAOMSF(0))
IF '$DATA(AQAOMSF(AQAOIND))
QUIT
+13 ;date chk
SET AQAODT=$PIECE(AQAOS,U,4)
IF AQAODT<AQAOBD
QUIT
IF AQAODT>AQAOED
QUIT
+14 ;
+15 ; set variables for ^TMP nodes
+16 SET AQAOM=$SELECT(AQAOMSF=1:10,$PIECE(^AQAO(2,AQAOIND,1),U,3)]"":$PIECE(^(1),U,3),1:10)
+17 ;S AQAOM=$P(^AQAO(2,AQAOIND,1),U,3) ;msf for ind
+18 ;S:AQAOM="" AQAOM=10
+19 ;ind # & name
SET AQAOIND=$PIECE(^AQAO(2,AQAOIND,0),U)_U_AQAOIND
+20 ;no close data
IF '$DATA(^AQAOC(AQAOIFN,"FINAL"))
QUIT
SET S=^("FINAL")
+21 ;find
SET X=$PIECE(S,U,4)
SET AQAOF=$SELECT(X="":"??",1:$PIECE(^AQAO(8,X,0),U,2))
+22 ;action
SET X=$PIECE(S,U,6)
SET AQAOA=$SELECT(X="":"??",1:$PIECE(^AQAO(6,X,0),U,2))
+23 ;potential
SET X=$PIECE(S,U,3)
SET AQAOP=$SELECT(X="":" ",1:$PIECE(^AQAO1(3,X,0),U))
+24 ;outcome
SET X=$PIECE(S,U,7)
SET AQAOO=$SELECT(X="":" ",1:$PIECE(^AQAO1(3,X,0),U))
+25 ;ultimate
SET X=$PIECE(S,U,8)
SET AQAOU=$SELECT(X="":" ",1:$PIECE(^AQAO1(3,X,0),U))
+26 ;
+27 ;$L = 4
SET AQAOF=$EXTRACT(AQAOF_" ",1,4)
SET AQAOA=$EXTRACT(AQAOA_AQAOAP_" ",1,4)
+28 SET Z="/"
+29 SET X=AQAOCID_U_AQAOF_Z_AQAOA_Z_AQAOTYP_Z_AQAOLV_Z_Z_AQAOP_Z_AQAOO_Z_AQAOU
+30 SET ^TMP("AQAOPC8",$JOB,AQAOM,AQAOIND,AQAODT,AQAOIFN)=X
+31 ;
+32 ; increment counts
+33 SET X=AQAOF_Z_AQAOA_Z_AQAOTYP_Z_AQAOLV
+34 SET ^TMP("AQAOPC8A",$JOB,AQAOIND,X)=$GET(^TMP("AQAOPC8A",$JOB,AQAOIND,X))+1
+35 SET X=AQAOP_Z_AQAOO_Z_AQAOU
+36 SET ^TMP("AQAOPC8B",$JOB,AQAOIND,X)=$GET(^TMP("AQAOPC8B",$JOB,AQAOIND,X))+1
End DoDot:1
+37 ;
+38 ;
NEXT ; >> go to print rtn
+1 GOTO ^AQAOPC83
