ACHSCPTG.m

ACHSCPTG ; IHS/ITSC/PMF - COMPILE CHS CPT CODE REPORT-BY VENDOR/DETAILED ;   [ 10/16/2001   8:16 AM ]

 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001

 ;

 S ACHSDAT=ACHSBEG-1,C=0,ACHSFAC=DUZ(2)

GETDATE ;

 S ACHSDAT=$O(^ACHSF(ACHSFAC,"PDOS",ACHSDAT))

 I (ACHSDAT>ACHSEND)!(ACHSDAT="") D

 .I $D(ACHSVNDR(0)),'$D(^TMP("ACHSCPT",$J)) S ^TMP("ACHSCPT",$J,0)=""

 .I '$D(ACHSVNDR(0)),'$D(^TMP("ACHSCPT",$J)) S ^TMP("ACHSCPT",$J,ACHSVEN,0)=""

 G:ACHSDAT="" ^ACHSCPTH

 S ACHSDIEN=""

GETDIEN ;

 S ACHSDIEN=$O(^ACHSF(ACHSFAC,"PDOS",ACHSDAT,ACHSDIEN))

 G GETDATE:ACHSDIEN=""

 I '$D(^ACHSF(ACHSFAC,"D",ACHSDIEN,11,0)) G GETDIEN

GETDOC ;

 S D=$P($G(^ACHSF(ACHSFAC,"D",ACHSDIEN,0)),U)

 S ACHSDOC=$P($G(^ACHSF(ACHSFAC,"D",ACHSDIEN,0)),U,14)_"-"_$P($G(^AUTTAREA($P($G(^AUTTLOC(ACHSFAC,0)),U,4),0)),U,3)_$E($P($G(^AUTTLOC(ACHSFAC,0)),U,17),2,3)_"-"_D

GETVNDR ;

 S ACHSVEND=$P($G(^ACHSF(ACHSFAC,"D",ACHSDIEN,0)),U,8)

 I $D(ACHSVNDR(0)) G GETCODE

 I ACHSVEND'=ACHSVEN G GETDIEN

GETCODE ;

 S (I,ACHS43,ACHS57,ACHS64,ACHSCPTA)=0

 F  S I=$O(^ACHSF(ACHSFAC,"D",ACHSDIEN,11,I)) Q:'I  D

 .S ACHSCODE=$P($P($G(^ACHSF(ACHSFAC,"D",ACHSDIEN,11,I,0)),U),";")

 .I '$D(ACHSCODE(0))&'$D(ACHSCODE(ACHSCODE)) Q

 .S ACHSCHB=$P($G(^ACHSF(ACHSFAC,"D",ACHSDIEN,11,I,0)),U,5)

 .S ACHSCHA=$P($G(^ACHSF(ACHSFAC,"D",ACHSDIEN,11,I,0)),U,6)

 .S ACHSFROM=$P($G(^ACHSF(ACHSFAC,"D",ACHSDIEN,11,I,0)),U,2)

 .S ACHSTO=$P($G(^ACHSF(ACHSFAC,"D",ACHSDIEN,11,I,0)),U,3)

 .S ACHSWLU=$P($G(^ACHSF(ACHSFAC,"D",ACHSDIEN,11,I,0)),U,4)

 .S ACHSMGS=$P($G(^ACHSF(ACHSFAC,"D",ACHSDIEN,11,I,0)),U,7)

 .S ACHS2TH=$P($G(^ACHSF(ACHSFAC,"D",ACHSDIEN,11,I,0)),U,8)

 .S ACHSSURF=$P($G(^ACHSF(ACHSFAC,"D",ACHSDIEN,11,I,0)),U,9)

 .S ACHSSERV=$P($G(^ACHSF(ACHSFAC,"D",ACHSDIEN,0)),U,4)

 .S ^TMP("ACHSCPT",$J,ACHSVEND,ACHSCODE,ACHSDOC,I)=ACHSSERV_U_ACHSFROM_U_ACHSTO_U_ACHSWLU_U_ACHSCHB_U_ACHSCHA_U_ACHSMGS_U_ACHS2TH_U_ACHSSURF_U_ACHSVEND Q

 G GETDIEN

 ;

ACHSCPTG  ; IHS/ITSC/PMF - COMPILE CHS CPT CODE REPORT-BY VENDOR/DETAILED ;   [ 10/16/2001   8:16 AM ]

 +1       ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001

 +2       ;

 +3        SET ACHSDAT=ACHSBEG-1

           SET C=0

           SET ACHSFAC=DUZ(2)

GETDATE   ;

 +1        SET ACHSDAT=$ORDER(^ACHSF(ACHSFAC,"PDOS",ACHSDAT))

 +2        IF (ACHSDAT>ACHSEND)!(ACHSDAT="")

               Begin DoDot:1

 +3                IF $DATA(ACHSVNDR(0))

                       IF '$DATA(^TMP("ACHSCPT",$JOB))

                           SET ^TMP("ACHSCPT",$JOB,0)=""

 +4                IF '$DATA(ACHSVNDR(0))

                       IF '$DATA(^TMP("ACHSCPT",$JOB))

                           SET ^TMP("ACHSCPT",$JOB,ACHSVEN,0)=""

               End DoDot:1

 +5        IF ACHSDAT=""

               GOTO ^ACHSCPTH

 +6        SET ACHSDIEN=""

GETDIEN   ;

 +1        SET ACHSDIEN=$ORDER(^ACHSF(ACHSFAC,"PDOS",ACHSDAT,ACHSDIEN))

 +2        IF ACHSDIEN=""

               GOTO GETDATE

 +3        IF '$DATA(^ACHSF(ACHSFAC,"D",ACHSDIEN,11,0))

               GOTO GETDIEN

GETDOC    ;

 +1        SET D=$PIECE($GET(^ACHSF(ACHSFAC,"D",ACHSDIEN,0)),U)

 +2        SET ACHSDOC=$PIECE($GET(^ACHSF(ACHSFAC,"D",ACHSDIEN,0)),U,14)_"-"_$PIECE($GET(^AUTTAREA($PIECE($GET(^AUTTLOC(ACHSFAC,0)),U,4),0)),U,3)_$EXTRACT($PIECE($GET(^AUTTLOC(ACHSFAC,0)),U,17),2,3)_"-"_D

GETVNDR   ;

 +1        SET ACHSVEND=$PIECE($GET(^ACHSF(ACHSFAC,"D",ACHSDIEN,0)),U,8)

 +2        IF $DATA(ACHSVNDR(0))

               GOTO GETCODE

 +3        IF ACHSVEND'=ACHSVEN

               GOTO GETDIEN

GETCODE   ;

 +1        SET (I,ACHS43,ACHS57,ACHS64,ACHSCPTA)=0

 +2        FOR 

               SET I=$ORDER(^ACHSF(ACHSFAC,"D",ACHSDIEN,11,I))

               IF 'I

                   QUIT 

               Begin DoDot:1

 +3                SET ACHSCODE=$PIECE($PIECE($GET(^ACHSF(ACHSFAC,"D",ACHSDIEN,11,I,0)),U),";")

 +4                IF '$DATA(ACHSCODE(0))&'$DATA(ACHSCODE(ACHSCODE))

                       QUIT 

 +5                SET ACHSCHB=$PIECE($GET(^ACHSF(ACHSFAC,"D",ACHSDIEN,11,I,0)),U,5)

 +6                SET ACHSCHA=$PIECE($GET(^ACHSF(ACHSFAC,"D",ACHSDIEN,11,I,0)),U,6)

 +7                SET ACHSFROM=$PIECE($GET(^ACHSF(ACHSFAC,"D",ACHSDIEN,11,I,0)),U,2)

 +8                SET ACHSTO=$PIECE($GET(^ACHSF(ACHSFAC,"D",ACHSDIEN,11,I,0)),U,3)

 +9                SET ACHSWLU=$PIECE($GET(^ACHSF(ACHSFAC,"D",ACHSDIEN,11,I,0)),U,4)

 +10               SET ACHSMGS=$PIECE($GET(^ACHSF(ACHSFAC,"D",ACHSDIEN,11,I,0)),U,7)

 +11               SET ACHS2TH=$PIECE($GET(^ACHSF(ACHSFAC,"D",ACHSDIEN,11,I,0)),U,8)

 +12               SET ACHSSURF=$PIECE($GET(^ACHSF(ACHSFAC,"D",ACHSDIEN,11,I,0)),U,9)

 +13               SET ACHSSERV=$PIECE($GET(^ACHSF(ACHSFAC,"D",ACHSDIEN,0)),U,4)

 +14               SET ^TMP("ACHSCPT",$JOB,ACHSVEND,ACHSCODE,ACHSDOC,I)=ACHSSERV_U_ACHSFROM_U_ACHSTO_U_ACHSWLU_U_ACHSCHB_U_ACHSCHA_U_ACHSMGS_U_ACHS2TH_U_ACHSSURF_U_ACHSVEND

                   QUIT 

               End DoDot:1

 +15       GOTO GETDIEN

 +16      ;