QANQTOT ;GJC/HISC-QUARTERLY REPORT OF INVESTIGATIONS (REGIONAL) ;9/3/93 12:17
;;2.0;Incident Reporting;**21,25**;08/07/1992
;
I $G(DUZ)']"" D Q
. W !!?12,*7,"This option CANNOT properly identify you, exiting."
. D EXIT
S (QANMSSG,QANXIT,QAQQUIT)=0
D QUART I QAQQUIT D EXIT Q
D CHECK ;Data for quarter exists OR global lock times out, exiting!
I QANXIT D EXIT Q
S QANBEG=QUBEG(QU)-.0000001,QANEND=QUEND(QU)_".9999999"
S QANDATE=QUBEG(QU),QANTODAY=DT
F QANDT=QANBEG:0 S QANDT=$O(^QA(742.4,"BDT",QANDT)) Q:(QANDT>QANEND)!(QANDT'>0) D
. F QANIEN=0:0 S QANIEN=$O(^QA(742.4,"BDT",QANDT,QANIEN)) Q:QANIEN'>0 D:'$D(^QA(742.4,"ACS",2,QANIEN)) PATFND
I '$D(^UTILITY($J,"QAN IR/PAT")) D Q
. W !!,*7,"No data found for the ",$S($G(QAQ2HED)]"":QAQ2HED,1:QUART),", exiting.",*7,!!
. D EXIT
F QANIEN=0:0 S QANIEN=$O(^UTILITY($J,"QAN IR/PAT",QANIEN)) Q:QANIEN'>0 D
. F QANPT=0:0 S QANPT=$O(^UTILITY($J,"QAN IR/PAT",QANIEN,QANPT)) Q:QANPT'>0 D TAB
D:'QANMSSG WAIT^DICD D ^QANQTTL ;Output of results.
D ^QANQSDT ;Generate a report based on the quarters data.
EXIT ;Kill and quit
D KILL^XUSCLEAN K ^UTILITY($J,"QAN IR/PAT")
Q
CHECK ;Check for existing quarterly data.
Q:'$D(^QA(742.6,"QDATE",QUBEG(QU))) ;no data
N Y S Y=QUBEG(QU) X ^DD("DD")
W !?5,"Quarterly Summary Data exists for the quarter beginning: ",Y
W !?5,"Do you wish to delete this quarters data?",*7 K DIR S DIR(0)="Y"
S DIR("?",1)="Enter ""Y"" to delete existing data AND calculate new data,",DIR("?")="Enter ""N"" to exit without updating data." D ^DIR K DIR
I 'Y S QANXIT=1 Q
S QANMSSG=1 D WAIT^DICD
L +^QA(742.6):5 ;Lock our global.
I '$T S QANXIT=1 W !!,*7,"Another person is editing this file, try again later.",!!,*7 L -^QA(742.6) Q
K DIK S DIK="^QA(742.6," F DA=0:0 S DA=$O(^QA(742.6,"QDATE",QUBEG(QU),DA)) Q:DA'>0 D ^DIK
L -^QA(742.6) ;Unlock after update.
Q
PATFND ;Find the proper patient's ien for the associated incident.
;This subroutine is not referenced if $D(^QA(742.4,"ACS",2,QANIEN))
;this indicates a deleted incident record. Quit if the Bene Rpt flag
;is not set to '1'. Do not set utility if the patient record status
;is 'deleted'. PTCH 21 8/12/93
S QAN7424=$G(^QA(742.4,QANIEN,0)) Q:QAN7424']""!(+$P(QAN7424,U,17)'>0)
F QANPT=0:0 S QANPT=$O(^QA(742,"BCS",QANIEN,QANPT)) Q:QANPT'>0 D
. S:'$D(^QA(742,"BPRS",-1,QANPT)) ^UTILITY($J,"QAN IR/PAT",QANIEN,QANPT)=""
Q
QUART ;Choose the quarter and the year.
W !!,"Enter Quarter Period and FY you wish to end with",!
ENTERQ ;Enter the Quarter in question.
R !,"Enter Quarter and Year: ",QUART:DTIME S:'$T QUART="^" I (QUART="^")!(QUART="") S QAQQUIT=1 Q
I (QUART'?1N1P2N)&(QUART'?1N1P4N) W:$E(QUART)'="?" " ??",*7 W !!,"Enter Quarter Period in this format: 2nd quarter 1988 would be 2-88, 2/88, 2 88",! G ENTERQ
I ($E(QUART)>4)!($E(QUART)<1) W " ??",*7,!!,"Enter Quarter 1 to 4 only",! G ENTERQ
S QU=$E(QUART),YR=$E(QUART,3,6) K %DT S X=YR D ^%DT S YR=$E(Y,1,3)
S QUBEG(1)=YR-1_1001,QUBEG(2)=YR_"0101",QUBEG(3)=YR_"0401",QUBEG(4)=YR_"0701",QUEND(1)=YR-1_1231,QUEND(2)=YR_"0331",QUEND(3)=YR_"0630",QUEND(4)=YR_"0930",QUQUA(1)="FIRST",QUQUA(2)="SECOND",QUQUA(3)="THIRD",QUQUA(4)="FOURTH"
S QAQNBEG=QUBEG(QU),QAQNEND=QUEND(QU),QAQ2HED=QUQUA(QU)_" QUARTER FY "_(1700+YR)
Q
TAB ;Setting up the variables for tabulation.
S QAN742=$G(^QA(742,QANPT,0)) Q:QAN742']""
S QAN7424=$G(^QA(742.4,QANIEN,0)) Q:QAN7424']""
S QANMED=$P($P(QAN7424,U),"."),QANINCD=$P(QAN7424,U,2)
S QANINVST=$S(+$P(QAN7424,U,11)=2:1,1:0),QANDTH=+$P(QAN7424,U,14)
S QANALPV=+$P(QAN7424,U,16),QANSVLV=+$P(QAN742,U,10)
D PATTYPE I $D(^QA(742.1,"BUPPER","DEATH",QANINCD)),QANDTH D DTH
D INVNON
Q
DTH ;For Death
S QANDEATH=+$S($D(^QA(742.14,QANDTH,0)):$P(^(0),U,2),1:"") Q:'QANDEATH
I $D(QANARRY("QAN D",QANINCD,QANPTTY,QANDTH,QANINVST)) S QANARRY("QAN D",QANINCD,QANPTTY,QANDTH,QANINVST)=QANARRY("QAN D",QANINCD,QANPTTY,QANDTH,QANINVST)+1
E S QANARRY("QAN D",QANINCD,QANPTTY,QANDTH,QANINVST)=1
Q
INVNON ;Invest/Non Invest
I $D(QANARRY(QANINCD,QANALPV,QANPTTY,QANINVST)) S QANARRY(QANINCD,QANALPV,QANPTTY,QANINVST)=QANARRY(QANINCD,QANALPV,QANPTTY,QANINVST)+1
E S QANARRY(QANINCD,QANALPV,QANPTTY,QANINVST)=1
I $D(QANARRY(QANINCD,QANALPV,QANPTTY,QANINVST,QANSVLV)) S QANARRY(QANINCD,QANALPV,QANPTTY,QANINVST,QANSVLV)=QANARRY(QANINCD,QANALPV,QANPTTY,QANINVST,QANSVLV)+1
E S QANARRY(QANINCD,QANALPV,QANPTTY,QANINVST,QANSVLV)=1
Q
PATTYPE ;Finds the appropriate patient type.
S QANWD=$P(QAN742,U,6),QANPTTY=$S(+$P(QAN742,U,5)=1:"I",1:"O")
Q:QANWD']""
I $D(^SC(QANWD,42)) D
. S QANWD(1)=+$G(^SC(QANWD,42)) Q:QANWD(1)'>0
. S QANWD(2)=$P(^DIC(42,QANWD(1),0),U,3)
. S QANPTTY=$S(QANWD(2)="NH":"N",QANWD(2)="D":"D",1:"I")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQANQTOT 4758 printed Apr 09, 2024@21:01:27 Page 2
QANQTOT ;GJC/HISC-QUARTERLY REPORT OF INVESTIGATIONS (REGIONAL) ;9/3/93 12:17
+1 ;;2.0;Incident Reporting;**21,25**;08/07/1992
+2 ;
+3 IF $GET(DUZ)']""
Begin DoDot:1
+4 WRITE !!?12,*7,"This option CANNOT properly identify you, exiting."
+5 DO EXIT
End DoDot:1
QUIT
+6 SET (QANMSSG,QANXIT,QAQQUIT)=0
+7 DO QUART
IF QAQQUIT
DO EXIT
QUIT
+8 ;Data for quarter exists OR global lock times out, exiting!
DO CHECK
+9 IF QANXIT
DO EXIT
QUIT
+10 SET QANBEG=QUBEG(QU)-.0000001
SET QANEND=QUEND(QU)_".9999999"
+11 SET QANDATE=QUBEG(QU)
SET QANTODAY=DT
+12 FOR QANDT=QANBEG:0
SET QANDT=$ORDER(^QA(742.4,"BDT",QANDT))
if (QANDT>QANEND)!(QANDT'>0)
QUIT
Begin DoDot:1
+13 FOR QANIEN=0:0
SET QANIEN=$ORDER(^QA(742.4,"BDT",QANDT,QANIEN))
if QANIEN'>0
QUIT
if '$DATA(^QA(742.4,"ACS",2,QANIEN))
DO PATFND
End DoDot:1
+14 IF '$DATA(^UTILITY($JOB,"QAN IR/PAT"))
Begin DoDot:1
+15 WRITE !!,*7,"No data found for the ",$SELECT($GET(QAQ2HED)]"":QAQ2HED,1:QUART),", exiting.",*7,!!
+16 DO EXIT
End DoDot:1
QUIT
+17 FOR QANIEN=0:0
SET QANIEN=$ORDER(^UTILITY($JOB,"QAN IR/PAT",QANIEN))
if QANIEN'>0
QUIT
Begin DoDot:1
+18 FOR QANPT=0:0
SET QANPT=$ORDER(^UTILITY($JOB,"QAN IR/PAT",QANIEN,QANPT))
if QANPT'>0
QUIT
DO TAB
End DoDot:1
+19 ;Output of results.
if 'QANMSSG
DO WAIT^DICD
DO ^QANQTTL
+20 ;Generate a report based on the quarters data.
DO ^QANQSDT
EXIT ;Kill and quit
+1 DO KILL^XUSCLEAN
KILL ^UTILITY($JOB,"QAN IR/PAT")
+2 QUIT
CHECK ;Check for existing quarterly data.
+1 ;no data
if '$DATA(^QA(742.6,"QDATE",QUBEG(QU)))
QUIT
+2 NEW Y
SET Y=QUBEG(QU)
XECUTE ^DD("DD")
+3 WRITE !?5,"Quarterly Summary Data exists for the quarter beginning: ",Y
+4 WRITE !?5,"Do you wish to delete this quarters data?",*7
KILL DIR
SET DIR(0)="Y"
+5 SET DIR("?",1)="Enter ""Y"" to delete existing data AND calculate new data,"
SET DIR("?")="Enter ""N"" to exit without updating data."
DO ^DIR
KILL DIR
+6 IF 'Y
SET QANXIT=1
QUIT
+7 SET QANMSSG=1
DO WAIT^DICD
+8 ;Lock our global.
LOCK +^QA(742.6):5
+9 IF '$TEST
SET QANXIT=1
WRITE !!,*7,"Another person is editing this file, try again later.",!!,*7
LOCK -^QA(742.6)
QUIT
+10 KILL DIK
SET DIK="^QA(742.6,"
FOR DA=0:0
SET DA=$ORDER(^QA(742.6,"QDATE",QUBEG(QU),DA))
if DA'>0
QUIT
DO ^DIK
+11 ;Unlock after update.
LOCK -^QA(742.6)
+12 QUIT
PATFND ;Find the proper patient's ien for the associated incident.
+1 ;This subroutine is not referenced if $D(^QA(742.4,"ACS",2,QANIEN))
+2 ;this indicates a deleted incident record. Quit if the Bene Rpt flag
+3 ;is not set to '1'. Do not set utility if the patient record status
+4 ;is 'deleted'. PTCH 21 8/12/93
+5 SET QAN7424=$GET(^QA(742.4,QANIEN,0))
if QAN7424']""!(+$PIECE(QAN7424,U,17)'>0)
QUIT
+6 FOR QANPT=0:0
SET QANPT=$ORDER(^QA(742,"BCS",QANIEN,QANPT))
if QANPT'>0
QUIT
Begin DoDot:1
+7 if '$DATA(^QA(742,"BPRS",-1,QANPT))
SET ^UTILITY($JOB,"QAN IR/PAT",QANIEN,QANPT)=""
End DoDot:1
+8 QUIT
QUART ;Choose the quarter and the year.
+1 WRITE !!,"Enter Quarter Period and FY you wish to end with",!
ENTERQ ;Enter the Quarter in question.
+1 READ !,"Enter Quarter and Year: ",QUART:DTIME
if '$TEST
SET QUART="^"
IF (QUART="^")!(QUART="")
SET QAQQUIT=1
QUIT
+2 IF (QUART'?1N1P2N)&(QUART'?1N1P4N)
if $EXTRACT(QUART)'="?"
WRITE " ??",*7
WRITE !!,"Enter Quarter Period in this format: 2nd quarter 1988 would be 2-88, 2/88, 2 88",!
GOTO ENTERQ
+3 IF ($EXTRACT(QUART)>4)!($EXTRACT(QUART)<1)
WRITE " ??",*7,!!,"Enter Quarter 1 to 4 only",!
GOTO ENTERQ
+4 SET QU=$EXTRACT(QUART)
SET YR=$EXTRACT(QUART,3,6)
KILL %DT
SET X=YR
DO ^%DT
SET YR=$EXTRACT(Y,1,3)
+5 SET QUBEG(1)=YR-1_1001
SET QUBEG(2)=YR_"0101"
SET QUBEG(3)=YR_"0401"
SET QUBEG(4)=YR_"0701"
SET QUEND(1)=YR-1_1231
SET QUEND(2)=YR_"0331"
SET QUEND(3)=YR_"0630"
SET QUEND(4)=YR_"0930"
SET QUQUA(1)="FIRST"
SET QUQUA(2)="SECOND"
SET QUQUA(3)="THIRD"
SET QUQUA(4)="FOURTH"
+6 SET QAQNBEG=QUBEG(QU)
SET QAQNEND=QUEND(QU)
SET QAQ2HED=QUQUA(QU)_" QUARTER FY "_(1700+YR)
+7 QUIT
TAB ;Setting up the variables for tabulation.
+1 SET QAN742=$GET(^QA(742,QANPT,0))
if QAN742']""
QUIT
+2 SET QAN7424=$GET(^QA(742.4,QANIEN,0))
if QAN7424']""
QUIT
+3 SET QANMED=$PIECE($PIECE(QAN7424,U),".")
SET QANINCD=$PIECE(QAN7424,U,2)
+4 SET QANINVST=$SELECT(+$PIECE(QAN7424,U,11)=2:1,1:0)
SET QANDTH=+$PIECE(QAN7424,U,14)
+5 SET QANALPV=+$PIECE(QAN7424,U,16)
SET QANSVLV=+$PIECE(QAN742,U,10)
+6 DO PATTYPE
IF $DATA(^QA(742.1,"BUPPER","DEATH",QANINCD))
IF QANDTH
DO DTH
+7 DO INVNON
+8 QUIT
DTH ;For Death
+1 SET QANDEATH=+$SELECT($DATA(^QA(742.14,QANDTH,0)):$PIECE(^(0),U,2),1:"")
if 'QANDEATH
QUIT
+2 IF $DATA(QANARRY("QAN D",QANINCD,QANPTTY,QANDTH,QANINVST))
SET QANARRY("QAN D",QANINCD,QANPTTY,QANDTH,QANINVST)=QANARRY("QAN D",QANINCD,QANPTTY,QANDTH,QANINVST)+1
+3 IF '$TEST
SET QANARRY("QAN D",QANINCD,QANPTTY,QANDTH,QANINVST)=1
+4 QUIT
INVNON ;Invest/Non Invest
+1 IF $DATA(QANARRY(QANINCD,QANALPV,QANPTTY,QANINVST))
SET QANARRY(QANINCD,QANALPV,QANPTTY,QANINVST)=QANARRY(QANINCD,QANALPV,QANPTTY,QANINVST)+1
+2 IF '$TEST
SET QANARRY(QANINCD,QANALPV,QANPTTY,QANINVST)=1
+3 IF $DATA(QANARRY(QANINCD,QANALPV,QANPTTY,QANINVST,QANSVLV))
SET QANARRY(QANINCD,QANALPV,QANPTTY,QANINVST,QANSVLV)=QANARRY(QANINCD,QANALPV,QANPTTY,QANINVST,QANSVLV)+1
+4 IF '$TEST
SET QANARRY(QANINCD,QANALPV,QANPTTY,QANINVST,QANSVLV)=1
+5 QUIT
PATTYPE ;Finds the appropriate patient type.
+1 SET QANWD=$PIECE(QAN742,U,6)
SET QANPTTY=$SELECT(+$PIECE(QAN742,U,5)=1:"I",1:"O")
+2 if QANWD']""
QUIT
+3 IF $DATA(^SC(QANWD,42))
Begin DoDot:1
+4 SET QANWD(1)=+$GET(^SC(QANWD,42))
if QANWD(1)'>0
QUIT
+5 SET QANWD(2)=$PIECE(^DIC(42,QANWD(1),0),U,3)
+6 SET QANPTTY=$SELECT(QANWD(2)="NH":"N",QANWD(2)="D":"D",1:"I")
End DoDot:1
+7 QUIT
