AQAOPR72 ; IHS/ORDC/LJF - PRINT REVIEWED OCC RPRT ;
;;1.01;QAI MANAGEMENT;;OCT 05, 1995
;
;This rtn prints the occurrences by indicator listing all reviews
;performed and who performed them.
;
INIT ; >>> initialize variables
D INIT^AQAOUTIL S AQAOHCON="Patient"
S AQAOTY="REVIEWED OCCURRENCES REPORT"
S AQAORG=$E(AQAOBD,4,5)_"/"_$E(AQAOBD,6,7)_"/"_$E(AQAOBD,2,3)_" to "
S AQAORG=AQAORG_$E(AQAOED,4,5)_"/"_$E(AQAOED,6,7)_"/"_$E(AQAOED,2,3)
S AQAONOT=0 ;counter for occ not reviewed
K ^TMP("AQAO",$J)
;
MAIN ; >>> main calls
I '$D(^TMP("AQAOPR7A",$J)) D
.D HEADING^AQAOUTIL,HDG1
.W !!,"NO DATA FOUND FOR DATE RANGE SPECIFIED",!!
E D LISTING I AQAOSTOP'=U D SUMMARY^AQAOPR73
;
END ; >>> eoj
D ^%ZISC I '$D(ZTQUEUED) D PRTOPT^AQAOVAR
K ^TMP("AQAOPR7",$J),^TMP("AQAOPR7A",$J),^TMP("AQAO",$J)
K AQAOINAC D KILL^AQAOUTIL Q
;
;
LISTING ; >> SUBRTN to print occurrence listing if selected
D HEADING^AQAOUTIL,HDG1
;
S AQAOIND=0 ;loop by indicator and print occurrences
F S AQAOIND=$O(^TMP("AQAOPR7A",$J,AQAOIND)) Q:AQAOIND="" Q:AQAOSTOP=U D
.D LIST2 Q:AQAOSTOP=U ;list each occ with reviews
Q
;
;
LIST2 ; >> SUBRTN for each AQAOIND list occ with reviews
I AQAOIND'=0 W !!?AQAOIOMX-$L(AQAOIND)/2,AQAOIND,!
S AQAODT=0
F S AQAODT=$O(^TMP("AQAOPR7A",$J,AQAOIND,AQAODT)) Q:AQAODT="" Q:AQAOSTOP=U D
.S AQAON=0
.F S AQAON=$O(^TMP("AQAOPR7A",$J,AQAOIND,AQAODT,AQAON)) Q:AQAON="" Q:AQAOSTOP=U D
..S AQAOSTR=$G(^AQAOC(AQAON,0)),AQAOSTR1=$G(^(1)) ;basic occ data
..I $Y>(IOSL-2) D NEWPG^AQAOUTIL Q:AQAOSTOP=U D HDG1
..S Y=AQAODT X ^DD("DD") W !,$P(AQAOSTR,U),?9,Y ;print case & date
..K ^UTILITY("DIQ1",$J) S DIC="^AQAOC(",DA=AQAON,DR=".025" D EN^DIQ1
..W ?22,$S(+AQAOSTR1=0:"OPEN",+AQAOSTR1=1:"CLOSED",1:"DELETED") ;status
..;
..D FINDING
Q
;
;
FINDING ; >> SUBRTN to find findings,etc. for occ
;get initial finding and action
S AQAOW=$P($G(^AQAOC(AQAON,1)),U,8) ;review date
S AQAOX=$P($G(^AQAOC(AQAON,1)),U,5) ;finding
S AQAOY=$P($G(^AQAOC(AQAON,1)),U,4) ;reviewer
S AQAOZ=$P($G(^AQAOC(AQAON,1)),U,6) ;action
S X=$P($G(^AQAOC(AQAON,1)),U,9) ;referred to;PATCH 3
I X]"" S AQAOAR(1)=X,X=1,Y=0 F S Y=$O(^AQAOC(AQAON,"IADDRV",Y)) Q:Y'=+Y D ;PATCH 3
.S X=X+1,AQAOAR(X)=$P($G(^AQAOC(AQAON,"IADDRV",Y,0)),U) ;addl referrals
I AQAOW="" S AQAONOT=AQAONOT+1 Q ;occ not reviewed
W !?22,"Reviews:"
D PRINTREV K AQAOAR
;
S AQAOR=0 F S AQAOR=$O(^AQAOC(AQAON,"REV",AQAOR)) Q:AQAOR'=+AQAOR D
.S AQAOW=$P(^AQAOC(AQAON,"REV",AQAOR,0),U,4) ;review date
.S AQAOX=$P(^AQAOC(AQAON,"REV",AQAOR,0),U,5) ;finding
.S AQAOY=$P(^AQAOC(AQAON,"REV",AQAOR,0),U,2) ;reviewer
.S AQAOZ=$P(^AQAOC(AQAON,"REV",AQAOR,0),U,7) ;action
.S (X,Y)=0 F S Y=$O(^AQAOC(AQAON,"REV",AQAOR,"ADDRV",Y)) Q:Y'=+Y D
..S X=X+1,AQAOAR(X)=$P($G(^AQAOC(AQAON,"REV",AQAOR,"ADDRV",Y,0)),U)
.D PRINTREV K AQAOAR
;
I $P(^AQAOC(AQAON,1),U)=1 D ;closed occurrences
.S AQAOW=$P($G(^AQAOC(AQAON,"FINAL")),U) ;review date
.S AQAOX=$P($G(^AQAOC(AQAON,"FINAL")),U,4) ;finding
.S AQAOY=$P($G(^AQAOC(AQAON,"FINAL")),U,5)_";VA(200," ;reviewer
.S AQAOZ=$P($G(^AQAOC(AQAON,"FINAL")),U,6) ;action
.D PRINTREV
Q
;
;
PRINTREV ; SUBRTN to print rev date,reviewer,finding,action
Q:AQAOW=""
S Y=AQAOW,C=$P(^DD(9002167,.18,0),U,2) D Y^DIQ W ?32,Y ;review date
S Y=AQAOY,C=$P(^DD(9002167,.14,0),U,2) D Y^DIQ ;reviewer
W ?47,$$NAME
I Y]"" S ^TMP("AQAO",$J,Y,AQAOIND,AQAON)=""
S Y=$S(AQAOX="":"",1:$P($G(^AQAO(8,AQAOX,0)),U,2)) W ?62,Y ;finding
S Y=$S(AQAOZ="":"",1:$P($G(^AQAO(6,AQAOZ,0)),U,2)) W ?72,Y ;action
I $D(AQAOAR) S AQAOX=0 F S AQAOX=$O(AQAOAR(AQAOX)) Q:AQAOX="" D
.W:AQAOX=1 !?47,"Referred to:" W:AQAOX>1 !
.S Y=AQAOAR(AQAOX),C=$P(^DD(9002167,.19,0),U,2) D Y^DIQ ;referrals
.W ?62,$$NAME
W ! Q
;
;
HDG1 ; >> SUBRTN for second half of heading
W ?30,AQAORG,!,AQAOLINE
W !,"Case #",?9,"Occ Date",?22,"Status"
W ?32,"Rev Date",?47,"Revwr",?62,"Finding",?72,"Action"
W !,AQAOLINE
Q
;
;
HDG2 ; >> SUBRTN for second half of heading2
W ?33,"(SUMMARY PAGE)",!?30,AQAORG,!,AQAOLINE,!
Q
;
;
NAME() ; >> EXTRN VAR for printing names
I Y'["," S Y=$E(Y,1,12) Q Y
S Y=$P(Y,",")_","_$E($P(Y,",",2),1),Y=$E(Y,1,12) Q Y
AQAOPR72 ; IHS/ORDC/LJF - PRINT REVIEWED OCC RPRT ;
+1 ;;1.01;QAI MANAGEMENT;;OCT 05, 1995
+2 ;
+3 ;This rtn prints the occurrences by indicator listing all reviews
+4 ;performed and who performed them.
+5 ;
INIT ; >>> initialize variables
+1 DO INIT^AQAOUTIL
SET AQAOHCON="Patient"
+2 SET AQAOTY="REVIEWED OCCURRENCES REPORT"
+3 SET AQAORG=$EXTRACT(AQAOBD,4,5)_"/"_$EXTRACT(AQAOBD,6,7)_"/"_$EXTRACT(AQAOBD,2,3)_" to "
+4 SET AQAORG=AQAORG_$EXTRACT(AQAOED,4,5)_"/"_$EXTRACT(AQAOED,6,7)_"/"_$EXTRACT(AQAOED,2,3)
+5 ;counter for occ not reviewed
SET AQAONOT=0
+6 KILL ^TMP("AQAO",$JOB)
+7 ;
MAIN ; >>> main calls
+1 IF '$DATA(^TMP("AQAOPR7A",$JOB))
Begin DoDot:1
+2 DO HEADING^AQAOUTIL
DO HDG1
+3 WRITE !!,"NO DATA FOUND FOR DATE RANGE SPECIFIED",!!
End DoDot:1
+4 IF '$TEST
DO LISTING
IF AQAOSTOP'=U
DO SUMMARY^AQAOPR73
+5 ;
END ; >>> eoj
+1 DO ^%ZISC
IF '$DATA(ZTQUEUED)
DO PRTOPT^AQAOVAR
+2 KILL ^TMP("AQAOPR7",$JOB),^TMP("AQAOPR7A",$JOB),^TMP("AQAO",$JOB)
+3 KILL AQAOINAC
DO KILL^AQAOUTIL
QUIT
+4 ;
+5 ;
LISTING ; >> SUBRTN to print occurrence listing if selected
+1 DO HEADING^AQAOUTIL
DO HDG1
+2 ;
+3 ;loop by indicator and print occurrences
SET AQAOIND=0
+4 FOR
SET AQAOIND=$ORDER(^TMP("AQAOPR7A",$JOB,AQAOIND))
IF AQAOIND=""
QUIT
IF AQAOSTOP=U
QUIT
Begin DoDot:1
+5 ;list each occ with reviews
DO LIST2
IF AQAOSTOP=U
QUIT
End DoDot:1
+6 QUIT
+7 ;
+8 ;
LIST2 ; >> SUBRTN for each AQAOIND list occ with reviews
+1 IF AQAOIND'=0
WRITE !!?AQAOIOMX-$LENGTH(AQAOIND)/2,AQAOIND,!
+2 SET AQAODT=0
+3 FOR
SET AQAODT=$ORDER(^TMP("AQAOPR7A",$JOB,AQAOIND,AQAODT))
IF AQAODT=""
QUIT
IF AQAOSTOP=U
QUIT
Begin DoDot:1
+4 SET AQAON=0
+5 FOR
SET AQAON=$ORDER(^TMP("AQAOPR7A",$JOB,AQAOIND,AQAODT,AQAON))
IF AQAON=""
QUIT
IF AQAOSTOP=U
QUIT
Begin DoDot:2
+6 ;basic occ data
SET AQAOSTR=$GET(^AQAOC(AQAON,0))
SET AQAOSTR1=$GET(^(1))
+7 IF $Y>(IOSL-2)
DO NEWPG^AQAOUTIL
IF AQAOSTOP=U
QUIT
DO HDG1
+8 ;print case & date
SET Y=AQAODT
XECUTE ^DD("DD")
WRITE !,$PIECE(AQAOSTR,U),?9,Y
+9 KILL ^UTILITY("DIQ1",$JOB)
SET DIC="^AQAOC("
SET DA=AQAON
SET DR=".025"
DO EN^DIQ1
+10 ;status
WRITE ?22,$SELECT(+AQAOSTR1=0:"OPEN",+AQAOSTR1=1:"CLOSED",1:"DELETED")
+11 ;
+12 DO FINDING
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
+15 ;
FINDING ; >> SUBRTN to find findings,etc. for occ
+1 ;get initial finding and action
+2 ;review date
SET AQAOW=$PIECE($GET(^AQAOC(AQAON,1)),U,8)
+3 ;finding
SET AQAOX=$PIECE($GET(^AQAOC(AQAON,1)),U,5)
+4 ;reviewer
SET AQAOY=$PIECE($GET(^AQAOC(AQAON,1)),U,4)
+5 ;action
SET AQAOZ=$PIECE($GET(^AQAOC(AQAON,1)),U,6)
+6 ;referred to;PATCH 3
SET X=$PIECE($GET(^AQAOC(AQAON,1)),U,9)
+7 ;PATCH 3
IF X]""
SET AQAOAR(1)=X
SET X=1
SET Y=0
FOR
SET Y=$ORDER(^AQAOC(AQAON,"IADDRV",Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+8 ;addl referrals
SET X=X+1
SET AQAOAR(X)=$PIECE($GET(^AQAOC(AQAON,"IADDRV",Y,0)),U)
End DoDot:1
+9 ;occ not reviewed
IF AQAOW=""
SET AQAONOT=AQAONOT+1
QUIT
+10 WRITE !?22,"Reviews:"
+11 DO PRINTREV
KILL AQAOAR
+12 ;
+13 SET AQAOR=0
FOR
SET AQAOR=$ORDER(^AQAOC(AQAON,"REV",AQAOR))
IF AQAOR'=+AQAOR
QUIT
Begin DoDot:1
+14 ;review date
SET AQAOW=$PIECE(^AQAOC(AQAON,"REV",AQAOR,0),U,4)
+15 ;finding
SET AQAOX=$PIECE(^AQAOC(AQAON,"REV",AQAOR,0),U,5)
+16 ;reviewer
SET AQAOY=$PIECE(^AQAOC(AQAON,"REV",AQAOR,0),U,2)
+17 ;action
SET AQAOZ=$PIECE(^AQAOC(AQAON,"REV",AQAOR,0),U,7)
+18 SET (X,Y)=0
FOR
SET Y=$ORDER(^AQAOC(AQAON,"REV",AQAOR,"ADDRV",Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+19 SET X=X+1
SET AQAOAR(X)=$PIECE($GET(^AQAOC(AQAON,"REV",AQAOR,"ADDRV",Y,0)),U)
End DoDot:2
+20 DO PRINTREV
KILL AQAOAR
End DoDot:1
+21 ;
+22 ;closed occurrences
IF $PIECE(^AQAOC(AQAON,1),U)=1
Begin DoDot:1
+23 ;review date
SET AQAOW=$PIECE($GET(^AQAOC(AQAON,"FINAL")),U)
+24 ;finding
SET AQAOX=$PIECE($GET(^AQAOC(AQAON,"FINAL")),U,4)
+25 ;reviewer
SET AQAOY=$PIECE($GET(^AQAOC(AQAON,"FINAL")),U,5)_";VA(200,"
+26 ;action
SET AQAOZ=$PIECE($GET(^AQAOC(AQAON,"FINAL")),U,6)
+27 DO PRINTREV
End DoDot:1
+28 QUIT
+29 ;
+30 ;
PRINTREV ; SUBRTN to print rev date,reviewer,finding,action
+1 IF AQAOW=""
QUIT
+2 ;review date
SET Y=AQAOW
SET C=$PIECE(^DD(9002167,.18,0),U,2)
DO Y^DIQ
WRITE ?32,Y
+3 ;reviewer
SET Y=AQAOY
SET C=$PIECE(^DD(9002167,.14,0),U,2)
DO Y^DIQ
+4 WRITE ?47,$$NAME
+5 IF Y]""
SET ^TMP("AQAO",$JOB,Y,AQAOIND,AQAON)=""
+6 ;finding
SET Y=$SELECT(AQAOX="":"",1:$PIECE($GET(^AQAO(8,AQAOX,0)),U,2))
WRITE ?62,Y
+7 ;action
SET Y=$SELECT(AQAOZ="":"",1:$PIECE($GET(^AQAO(6,AQAOZ,0)),U,2))
WRITE ?72,Y
+8 IF $DATA(AQAOAR)
SET AQAOX=0
FOR
SET AQAOX=$ORDER(AQAOAR(AQAOX))
IF AQAOX=""
QUIT
Begin DoDot:1
+9 IF AQAOX=1
WRITE !?47,"Referred to:"
IF AQAOX>1
WRITE !
+10 ;referrals
SET Y=AQAOAR(AQAOX)
SET C=$PIECE(^DD(9002167,.19,0),U,2)
DO Y^DIQ
+11 WRITE ?62,$$NAME
End DoDot:1
+12 WRITE !
QUIT
+13 ;
+14 ;
HDG1 ; >> SUBRTN for second half of heading
+1 WRITE ?30,AQAORG,!,AQAOLINE
+2 WRITE !,"Case #",?9,"Occ Date",?22,"Status"
+3 WRITE ?32,"Rev Date",?47,"Revwr",?62,"Finding",?72,"Action"
+4 WRITE !,AQAOLINE
+5 QUIT
+6 ;
+7 ;
HDG2 ; >> SUBRTN for second half of heading2
+1 WRITE ?33,"(SUMMARY PAGE)",!?30,AQAORG,!,AQAOLINE,!
+2 QUIT
+3 ;
+4 ;
NAME() ; >> EXTRN VAR for printing names
+1 IF Y'[","
SET Y=$EXTRACT(Y,1,12)
QUIT Y
+2 SET Y=$PIECE(Y,",")_","_$EXTRACT($PIECE(Y,",",2),1)
SET Y=$EXTRACT(Y,1,12)
QUIT Y
