ACHSOCSC ; IHS/ITSC/PMF - COMPILE CHS SERVICE CLASS CODES SUMMARY ; [ 10/14/2004 10:04 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**6,7,11**;JUNE 11,2001
;IHS/SET/JVK ACHS*3.1*6 7/1/03 NEW CODE TO BAL REGISTERS
;ITSC/SET/JVK ACHS*3.1*7 10-29-03 - ADD COUNT OF BLANKETS,PAID DOCS
;ITSC/SET/JVK ACHS*3.1*11 ADD SORT BY FY & PAY END DATE
;
K ^TMP("ACHSOCSQ",$J)
;IHS/SET/JVK ACHS*3.1*6 NEW CODE
S ACHSOBX=0
S ACHSZAT=0
;IHS/SET/JVK ACHS*3.1*6 END CODE
S ACHSPSCC=0
;
I ACHSBDT S ACHSBDTC=ACHSBDT-1 G BYDATES
S ACHSFY1="1"_$E(ACHSFY,4)_"00000"
PONUM ;
S ACHSFY1=$O(^ACHSF(ACHSFAC,"D","B",ACHSFY1))
G:ACHSFY1="" ^ACHSOCSP
I $E(ACHSFY1,2)'=$E(ACHSFY,4) G PONUM
S ACHSDIEN=""
GETDEN ;
S ACHSDIEN=$O(^ACHSF(ACHSFAC,"D","B",ACHSFY1,ACHSDIEN))
G:ACHSDIEN="" PONUM
D DOCUMENT
G GETDEN
;
BYDATES ;
A ;
S ACHSBDTC=$O(^ACHSF(ACHSFAC,"TB",ACHSBDTC))
G:+ACHSBDTC=0!(+ACHSBDTC>ACHSEDT) ^ACHSOCSP
B ;
S ACHSDIEN=0
C ;
S ACHSDIEN=$O(^ACHSF(ACHSFAC,"TB",ACHSBDTC,"I",ACHSDIEN))
G A:+ACHSDIEN=0
D DOCUMENT
G C
;
DOCUMENT ;
I '$D(^ACHSF(ACHSFAC,"D",ACHSDIEN,0)) Q
I $P(^ACHSF(ACHSFAC,"D",ACHSDIEN,0),U,9)'>0 Q
;ITSC/SET/JVK ACHS*3.1*11 LINE BELOW
I ACHSRTY=3,$P($G(^ACHSF(ACHSFAC,"D",ACHSDIEN,"PA")),U,3)>ACHSEDT Q
;
D GETINFO
Q
;
GETINFO ; Count docs, retrieve obligated and paid amounts.
S ACHSOC=$P(^ACHSF(ACHSFAC,"D",ACHSDIEN,0),U,7)
I '$D(^ACHS(3,ACHSFAC,1,ACHSOC,0)) Q
S ACHSOC=$P(^ACHS(3,ACHSFAC,1,ACHSOC,0),U)_" -"_$P(^ACHS(3,ACHSFAC,1,ACHSOC,0),U,2)
I '$D(^TMP("ACHSOCSQ",$J,ACHSFAC,ACHSOC)) S ^TMP("ACHSOCSQ",$J,ACHSFAC,ACHSOC)=""
S ACHSPMT=$S($D(^ACHSF(ACHSFAC,"D",ACHSDIEN,"PA")):$P(^("PA"),U,1),1:0)
;IHS/SET/JVK ACHS*3.1*6 BEG NEW CODE
;I $D(^ACHSF(ACHSFAC,"D",ACHSDIEN,"PA")) S ACHSOB1=$S(+$P(^ACHSF(ACHSFAC,"D",ACHSDIEN,"PA"),U,2):$P(^("PA"),U,2),1:0) S ACHSOBX=ACHSOB1+ACHSOBX
;ITSC/SET/JVK ADD COUNT OF DOC'S PAID
I $D(^ACHSF(ACHSFAC,"D",ACHSDIEN,"PA")) S ACHSOB1=$S(+$P(^ACHSF(ACHSFAC,"D",ACHSDIEN,"PA"),U,2):$P(^("PA"),U,2),1:0) S ACHSOBX=ACHSOB1+ACHSOBX,ACHSPSCC=ACHSPSCC+1
;I $D(^ACHSF(ACHSFAC,"D",ACHSDIEN,"ZA")) S ACHSADJ=$S($P(^ACHSF(ACHSFAC,"D",ACHSDIEN,"ZA"),U,2):$P(^("ZA"),U,2),1:0) S ACHSPMT=ACHSPMT+ACHSADJ
I $D(^ACHSF(ACHSFAC,"D",ACHSDIEN,"ZA")) S ACHSADJ=$S($P(^ACHSF(ACHSFAC,"D",ACHSDIEN,"ZA"),U,2):$P(^("ZA"),U,2),1:0) S ACHSPMT=ACHSPMT+ACHSADJ,ACHSZAT=ACHSADJ+ACHSZAT
;IHS/SET/JVK ACHS*3.1*6 END NEW CODE
S $P(^TMP("ACHSOCSQ",$J,ACHSFAC,ACHSOC),U,1)=$P(^TMP("ACHSOCSQ",$J,ACHSFAC,ACHSOC),U,1)+1
S $P(^TMP("ACHSOCSQ",$J,ACHSFAC,ACHSOC),U,2)=$P(^TMP("ACHSOCSQ",$J,ACHSFAC,ACHSOC),U,2)+$P(^ACHSF(ACHSFAC,"D",ACHSDIEN,0),U,9)
S $P(^TMP("ACHSOCSQ",$J,ACHSFAC,ACHSOC),U,3)=$P(^TMP("ACHSOCSQ",$J,ACHSFAC,ACHSOC),U,3)+ACHSPMT
S X=0
F %=0:0 S %=$O(^ACHSF(ACHSFAC,"D",ACHSDIEN,"T",%)) Q:'% S X=X+$P(^(%,0),U,9)
S $P(^TMP("ACHSOCSQ",$J,ACHSFAC,ACHSOC),U,4)=$P(^TMP("ACHSOCSQ",$J,ACHSFAC,ACHSOC),U,4)+X
;ITSC/SET/JVK ACHS*3.1*7 GET PAID NOS.
I $P(^ACHSF(ACHSFAC,"D",ACHSDIEN,0),U,12)=3 S $P(^TMP("ACHSOCSQ",$J,ACHSFAC,ACHSOC),U,5)=$P(^TMP("ACHSOCSQ",$J,ACHSFAC,ACHSOC),U,5)+1
I $P(^ACHSF(ACHSFAC,"D",ACHSDIEN,0),U,3)>0 S $P(^TMP("ACHSOCSQ",$J,ACHSFAC,ACHSOC),U,6)=$P(^TMP("ACHSOCSQ",$J,ACHSFAC,ACHSOC),U,6)+1
Q
;
ACHSOCSC ; IHS/ITSC/PMF - COMPILE CHS SERVICE CLASS CODES SUMMARY ; [ 10/14/2004 10:04 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**6,7,11**;JUNE 11,2001
+2 ;IHS/SET/JVK ACHS*3.1*6 7/1/03 NEW CODE TO BAL REGISTERS
+3 ;ITSC/SET/JVK ACHS*3.1*7 10-29-03 - ADD COUNT OF BLANKETS,PAID DOCS
+4 ;ITSC/SET/JVK ACHS*3.1*11 ADD SORT BY FY & PAY END DATE
+5 ;
+6 KILL ^TMP("ACHSOCSQ",$JOB)
+7 ;IHS/SET/JVK ACHS*3.1*6 NEW CODE
+8 SET ACHSOBX=0
+9 SET ACHSZAT=0
+10 ;IHS/SET/JVK ACHS*3.1*6 END CODE
+11 SET ACHSPSCC=0
+12 ;
+13 IF ACHSBDT
SET ACHSBDTC=ACHSBDT-1
GOTO BYDATES
+14 SET ACHSFY1="1"_$EXTRACT(ACHSFY,4)_"00000"
PONUM ;
+1 SET ACHSFY1=$ORDER(^ACHSF(ACHSFAC,"D","B",ACHSFY1))
+2 IF ACHSFY1=""
GOTO ^ACHSOCSP
+3 IF $EXTRACT(ACHSFY1,2)'=$EXTRACT(ACHSFY,4)
GOTO PONUM
+4 SET ACHSDIEN=""
GETDEN ;
+1 SET ACHSDIEN=$ORDER(^ACHSF(ACHSFAC,"D","B",ACHSFY1,ACHSDIEN))
+2 IF ACHSDIEN=""
GOTO PONUM
+3 DO DOCUMENT
+4 GOTO GETDEN
+5 ;
BYDATES ;
A ;
+1 SET ACHSBDTC=$ORDER(^ACHSF(ACHSFAC,"TB",ACHSBDTC))
+2 IF +ACHSBDTC=0!(+ACHSBDTC>ACHSEDT)
GOTO ^ACHSOCSP
B ;
+1 SET ACHSDIEN=0
C ;
+1 SET ACHSDIEN=$ORDER(^ACHSF(ACHSFAC,"TB",ACHSBDTC,"I",ACHSDIEN))
+2 IF +ACHSDIEN=0
GOTO A
+3 DO DOCUMENT
+4 GOTO C
+5 ;
DOCUMENT ;
+1 IF '$DATA(^ACHSF(ACHSFAC,"D",ACHSDIEN,0))
QUIT
+2 IF $PIECE(^ACHSF(ACHSFAC,"D",ACHSDIEN,0),U,9)'>0
QUIT
+3 ;ITSC/SET/JVK ACHS*3.1*11 LINE BELOW
+4 IF ACHSRTY=3
IF $PIECE($GET(^ACHSF(ACHSFAC,"D",ACHSDIEN,"PA")),U,3)>ACHSEDT
QUIT
+5 ;
+6 DO GETINFO
+7 QUIT
+8 ;
GETINFO ; Count docs, retrieve obligated and paid amounts.
+1 SET ACHSOC=$PIECE(^ACHSF(ACHSFAC,"D",ACHSDIEN,0),U,7)
+2 IF '$DATA(^ACHS(3,ACHSFAC,1,ACHSOC,0))
QUIT
+3 SET ACHSOC=$PIECE(^ACHS(3,ACHSFAC,1,ACHSOC,0),U)_" -"_$PIECE(^ACHS(3,ACHSFAC,1,ACHSOC,0),U,2)
+4 IF '$DATA(^TMP("ACHSOCSQ",$JOB,ACHSFAC,ACHSOC))
SET ^TMP("ACHSOCSQ",$JOB,ACHSFAC,ACHSOC)=""
+5 SET ACHSPMT=$SELECT($DATA(^ACHSF(ACHSFAC,"D",ACHSDIEN,"PA")):$PIECE(^("PA"),U,1),1:0)
+6 ;IHS/SET/JVK ACHS*3.1*6 BEG NEW CODE
+7 ;I $D(^ACHSF(ACHSFAC,"D",ACHSDIEN,"PA")) S ACHSOB1=$S(+$P(^ACHSF(ACHSFAC,"D",ACHSDIEN,"PA"),U,2):$P(^("PA"),U,2),1:0) S ACHSOBX=ACHSOB1+ACHSOBX
+8 ;ITSC/SET/JVK ADD COUNT OF DOC'S PAID
+9 IF $DATA(^ACHSF(ACHSFAC,"D",ACHSDIEN,"PA"))
SET ACHSOB1=$SELECT(+$PIECE(^ACHSF(ACHSFAC,"D",ACHSDIEN,"PA"),U,2):$PIECE(^("PA"),U,2),1:0)
SET ACHSOBX=ACHSOB1+ACHSOBX
SET ACHSPSCC=ACHSPSCC+1
+10 ;I $D(^ACHSF(ACHSFAC,"D",ACHSDIEN,"ZA")) S ACHSADJ=$S($P(^ACHSF(ACHSFAC,"D",ACHSDIEN,"ZA"),U,2):$P(^("ZA"),U,2),1:0) S ACHSPMT=ACHSPMT+ACHSADJ
+11 IF $DATA(^ACHSF(ACHSFAC,"D",ACHSDIEN,"ZA"))
SET ACHSADJ=$SELECT($PIECE(^ACHSF(ACHSFAC,"D",ACHSDIEN,"ZA"),U,2):$PIECE(^("ZA"),U,2),1:0)
SET ACHSPMT=ACHSPMT+ACHSADJ
SET ACHSZAT=ACHSADJ+ACHSZAT
+12 ;IHS/SET/JVK ACHS*3.1*6 END NEW CODE
+13 SET $PIECE(^TMP("ACHSOCSQ",$JOB,ACHSFAC,ACHSOC),U,1)=$PIECE(^TMP("ACHSOCSQ",$JOB,ACHSFAC,ACHSOC),U,1)+1
+14 SET $PIECE(^TMP("ACHSOCSQ",$JOB,ACHSFAC,ACHSOC),U,2)=$PIECE(^TMP("ACHSOCSQ",$JOB,ACHSFAC,ACHSOC),U,2)+$PIECE(^ACHSF(ACHSFAC,"D",ACHSDIEN,0),U,9)
+15 SET $PIECE(^TMP("ACHSOCSQ",$JOB,ACHSFAC,ACHSOC),U,3)=$PIECE(^TMP("ACHSOCSQ",$JOB,ACHSFAC,ACHSOC),U,3)+ACHSPMT
+16 SET X=0
+17 FOR %=0:0
SET %=$ORDER(^ACHSF(ACHSFAC,"D",ACHSDIEN,"T",%))
IF '%
QUIT
SET X=X+$PIECE(^(%,0),U,9)
+18 SET $PIECE(^TMP("ACHSOCSQ",$JOB,ACHSFAC,ACHSOC),U,4)=$PIECE(^TMP("ACHSOCSQ",$JOB,ACHSFAC,ACHSOC),U,4)+X
+19 ;ITSC/SET/JVK ACHS*3.1*7 GET PAID NOS.
+20 IF $PIECE(^ACHSF(ACHSFAC,"D",ACHSDIEN,0),U,12)=3
SET $PIECE(^TMP("ACHSOCSQ",$JOB,ACHSFAC,ACHSOC),U,5)=$PIECE(^TMP("ACHSOCSQ",$JOB,ACHSFAC,ACHSOC),U,5)+1
+21 IF $PIECE(^ACHSF(ACHSFAC,"D",ACHSDIEN,0),U,3)>0
SET $PIECE(^TMP("ACHSOCSQ",$JOB,ACHSFAC,ACHSOC),U,6)=$PIECE(^TMP("ACHSOCSQ",$JOB,ACHSFAC,ACHSOC),U,6)+1
+22 QUIT
+23 ;
