- 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 ;
