ACHSURT.m

ACHSURT ; IHS/ITSC/TPF/PMF - SELECT/DISPLAY RATE QUOTATIONS ;  

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

 ;ACHS*3.1*15;IHS.OIT.FCJ MODIFIED FORMAT FOR DISPLAYING RATE AND CONTRACT NUMBER NEW LENGTH

 ;

A1 ;EP

 S ACHSI=""

 S:'$D(ACHSCTNA) ACHSCTNA=0

A1A ;

 S ACHSI=$O(^AUTTVNDR(ACHSPROV,18,"AGR",ACHSI))

 Q:ACHSI=""

 S ACHSJ=""

A1C ;

 S ACHSJ=$O(^AUTTVNDR(ACHSPROV,18,"AGR",ACHSI,ACHSJ))

 G A1A:ACHSJ=""

 S X=$G(^AUTTVNDR(ACHSPROV,18,ACHSJ,0))   ;GET 'AGREEMENT/RATE/BPA NUMBER NODE

 S:'$D(ACHSRT(ACHSI)) ACHSRT(ACHSI)=0

 S ACHSRT(ACHSI)=ACHSRT(ACHSI)+1

 ;

 ;IF 'EFFECTIVE DATE' > EST. DATE OF SERVICE

 ;OR EST. DATE OF SERVICE > 'EXPIRATION DATE'

 I ($P(X,U,8)>ACHSEDOS)!(ACHSEDOS>$P(X,U,9)) G A1C

A1D ;

 S ACHSCTNA=ACHSCTNA+1

 S ACHSRT(ACHSCTNA)=X

 S:'$D(ACHSRT(ACHSI,"ACTIVE")) ACHSRT(ACHSI,"ACTIVE")=0

 S ACHSRT(ACHSI,"ACTIVE")=$G(ACHSRT(ACHSI,"ACTIVE"))+1

 S:'$D(ACHSRT(0,"ACTIVE")) ACHSRT(0,"ACTIVE")=0

 S ACHSRT(0,"ACTIVE")=ACHSRT(0,"ACTIVE")+1

 S ACHSRT(ACHSI)=$G(ACHSRT(ACHSI))+1

 S X=$P(ACHSRT(ACHSCTNA),U,6),Y=$E(X,4,5)_"-"_$E(X,6,7)_"-"_$E(X,2,3),$P(ACHSRT(ACHSCTNA),U,6)=Y

 S X=$P(ACHSRT(ACHSCTNA),U,8),Y=$E(X,4,5)_"-"_$E(X,6,7)_"-"_$E(X,2,3),$P(ACHSRT(ACHSCTNA),U,8)=Y

 S X=$P(ACHSRT(ACHSCTNA),U,9),Y=$E(X,4,5)_"-"_$E(X,6,7)_"-"_$E(X,2,3),$P(ACHSRT(ACHSCTNA),U,9)=Y

 S $P(ACHSRT(ACHSCTNA),U,11)=ACHSJ

 G A1C

 ;

A2 ;EP

 I ACHSCTNA=1 S ACHSAGRN=1,ACHSAGRP=$P(ACHSRT(ACHSCTNA),U,11) G A2A

 G A3:'ACHSAGRN

A2A ;

 W !!,"Enter Corresponding CONTRACT, AGREEMENT OR RATE QUOTE #. "

 I ACHSAGRN,$D(ACHSRT(ACHSAGRN)) S ACHSI=ACHSAGRN,ACHSJ=$P(ACHSRT(ACHSAGRN),U,10) D NODISP W Y,"// "

 D READ^ACHSFU

 G:(Y?1"?".E)!(Y="?") A3

 I Y="@" S (ACHSAGRN,ACHSAGRP)="" W "  DELETED" Q

 S Y=$E(Y)

 Q:$D(DUOUT)!$D(DTOUT)!(Y="")

 I (Y>ACHSCTNA)!(Y<1) W !!,"Please enter 1 thru "_ACHSCTNA_" " G A2A

 S ACHSAGRN=+Y,ACHSAGRP=$P(ACHSRT(+Y),U,11),ACHSCONP=""

 S:$P(ACHSRT(+Y),U,10)="CNT" ACHSCONP=ACHSAGRP,ACHSAGRP=""

 G A2A

 ;

A3 ;

 D HDR:'$D(ACHSAHDR)

 S ACHSI=C

 I ACHSCTNA>C S ACHSI=0

A3B ;

 S ACHSI=$O(ACHSRT(ACHSI))

 G A2A:+ACHSI=0

 S ACHSJ=$P(ACHSRT(ACHSI),U,10)

 W !,$J(ACHSI,2),?3,ACHSJ

 D NODISP                    ;BPA AGREEMENT NUMBER DISPLAY

 ;W ?9,Y

 W ?8,Y

A3C ;

 W ?27,$P(ACHSRT(ACHSI),U,8),?36,$P(ACHSRT(ACHSI),U,9)

 I ACHSJ="CNT" W ?49,$P(ACHSRT(ACHSI),U,2),! G A3B

 S X=$P(ACHSRT(ACHSI),U,4)

 I X="",($P(ACHSRT(ACHSI),U,2)="") G A3D

 S Y=$S(X="Y":"YES",X="N":" NO",1:"   ")

 I Y="   ",$P(ACHSRT(ACHSI),U,2)="" G A3D

 S Y=Y_"INP: "

 S:$P(ACHSRT(ACHSI),U,2)'="" Y=Y_$P(ACHSRT(ACHSI),U,2)

 W ?46,Y,!

A3D ;

 S X=$P(ACHSRT(ACHSI),U,5)

 I X=""&($P(ACHSRT(ACHSI),U,3)="") G A3E

 S Y=$S(X="Y":"YES",X="N":" NO",1:"   ")

 I Y="   ",$P(ACHSRT(ACHSI),U,3)="" G A3E

 S Y=Y_"  OUT: "

 S:$P(ACHSRT(ACHSI),U,3)'="" Y=Y_$P(ACHSRT(ACHSI),U,3)

 W ?46,Y,!

A3E ;

 W:$P(ACHSRT(ACHSI),U,7)'="" ?49,"PRO: ",$P(ACHSRT(ACHSI),U,7),!

 G A3B

 ;

EXIT ;

 K Y,X,ACHSCT

 Q

 ;

HDR ;

 ;W !!," #",?3,"Type",?9,"Number",?20,"Eff-Date",?30,"Exp-Date",?40,"MCR",?45,"Description",!?3,"----",?9,"---------",?20,"--------",?30,"--------",?40,"---",?45,"----------------------------"

 W !!," #",?3,"Type",?14,"Number",?27,"Eff-Date",?36,"Exp-Date",?45,"MCR",?49,"Description",!?3,"----",?8,"------------------",?27,"--------",?36,"--------",?45,"---",?49,"----------------------------"

 Q

 ;

NODISP ;DISPLAY BPA AGREEMENT STUFF

 S Y=""

 I ACHSJ="CNT" S Y=$P(ACHSRT(ACHSI),U) Q

 S Y=$E($P(ACHSRT(ACHSI),U),1,2)_$S(ACHSJ="BPA":"-A-",ACHSJ="PA":"-PA-",ACHSJ="RQ":"-R-",1:"")

 S X=$E($P(ACHSRT(ACHSI),U),3,6)

 I ACHSJ="RQ",$L($P(ACHSRT(ACHSI),U))>6 S Y=$P(ACHSRT(ACHSI),U) Q  ;ACHS*3.1*15 IHS.OIT.FCJ ADDED FOR NEW FORMAT OF RATE #

 I ACHSJ="PA" S Y=$S($L($P(ACHSRT(ACHSI),U))>6:$P(ACHSRT(ACHSI),U),1:Y_$E(X,2,4)) Q  ;ACHS*3.1*15 IHS.OIT.FCJ

 S Y=Y_$E(X,1,4)

 Q

 ;

ACHSURT   ; IHS/ITSC/TPF/PMF - SELECT/DISPLAY RATE QUOTATIONS ;  

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

 +2       ;ACHS*3.1*15;IHS.OIT.FCJ MODIFIED FORMAT FOR DISPLAYING RATE AND CONTRACT NUMBER NEW LENGTH

 +3       ;

A1        ;EP

 +1        SET ACHSI=""

 +2        IF '$DATA(ACHSCTNA)

               SET ACHSCTNA=0

A1A       ;

 +1        SET ACHSI=$ORDER(^AUTTVNDR(ACHSPROV,18,"AGR",ACHSI))

 +2        IF ACHSI=""

               QUIT 

 +3        SET ACHSJ=""

A1C       ;

 +1        SET ACHSJ=$ORDER(^AUTTVNDR(ACHSPROV,18,"AGR",ACHSI,ACHSJ))

 +2        IF ACHSJ=""

               GOTO A1A

 +3       ;GET 'AGREEMENT/RATE/BPA NUMBER NODE

           SET X=$GET(^AUTTVNDR(ACHSPROV,18,ACHSJ,0))

 +4        IF '$DATA(ACHSRT(ACHSI))

               SET ACHSRT(ACHSI)=0

 +5        SET ACHSRT(ACHSI)=ACHSRT(ACHSI)+1

 +6       ;

 +7       ;IF 'EFFECTIVE DATE' > EST. DATE OF SERVICE

 +8       ;OR EST. DATE OF SERVICE > 'EXPIRATION DATE'

 +9        IF ($PIECE(X,U,8)>ACHSEDOS)!(ACHSEDOS>$PIECE(X,U,9))

               GOTO A1C

A1D       ;

 +1        SET ACHSCTNA=ACHSCTNA+1

 +2        SET ACHSRT(ACHSCTNA)=X

 +3        IF '$DATA(ACHSRT(ACHSI,"ACTIVE"))

               SET ACHSRT(ACHSI,"ACTIVE")=0

 +4        SET ACHSRT(ACHSI,"ACTIVE")=$GET(ACHSRT(ACHSI,"ACTIVE"))+1

 +5        IF '$DATA(ACHSRT(0,"ACTIVE"))

               SET ACHSRT(0,"ACTIVE")=0

 +6        SET ACHSRT(0,"ACTIVE")=ACHSRT(0,"ACTIVE")+1

 +7        SET ACHSRT(ACHSI)=$GET(ACHSRT(ACHSI))+1

 +8        SET X=$PIECE(ACHSRT(ACHSCTNA),U,6)

           SET Y=$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,7)_"-"_$EXTRACT(X,2,3)

           SET $PIECE(ACHSRT(ACHSCTNA),U,6)=Y

 +9        SET X=$PIECE(ACHSRT(ACHSCTNA),U,8)

           SET Y=$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,7)_"-"_$EXTRACT(X,2,3)

           SET $PIECE(ACHSRT(ACHSCTNA),U,8)=Y

 +10       SET X=$PIECE(ACHSRT(ACHSCTNA),U,9)

           SET Y=$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,7)_"-"_$EXTRACT(X,2,3)

           SET $PIECE(ACHSRT(ACHSCTNA),U,9)=Y

 +11       SET $PIECE(ACHSRT(ACHSCTNA),U,11)=ACHSJ

 +12       GOTO A1C

 +13      ;

A2        ;EP

 +1        IF ACHSCTNA=1

               SET ACHSAGRN=1

               SET ACHSAGRP=$PIECE(ACHSRT(ACHSCTNA),U,11)

               GOTO A2A

 +2        IF 'ACHSAGRN

               GOTO A3

A2A       ;

 +1        WRITE !!,"Enter Corresponding CONTRACT, AGREEMENT OR RATE QUOTE #. "

 +2        IF ACHSAGRN

               IF $DATA(ACHSRT(ACHSAGRN))

                   SET ACHSI=ACHSAGRN

                   SET ACHSJ=$PIECE(ACHSRT(ACHSAGRN),U,10)

                   DO NODISP

                   WRITE Y,"// "

 +3        DO READ^ACHSFU

 +4        IF (Y?1"?".E)!(Y="?")

               GOTO A3

 +5        IF Y="@"

               SET (ACHSAGRN,ACHSAGRP)=""

               WRITE "  DELETED"

               QUIT 

 +6        SET Y=$EXTRACT(Y)

 +7        IF $DATA(DUOUT)!$DATA(DTOUT)!(Y="")

               QUIT 

 +8        IF (Y>ACHSCTNA)!(Y<1)

               WRITE !!,"Please enter 1 thru "_ACHSCTNA_" "

               GOTO A2A

 +9        SET ACHSAGRN=+Y

           SET ACHSAGRP=$PIECE(ACHSRT(+Y),U,11)

           SET ACHSCONP=""

 +10       IF $PIECE(ACHSRT(+Y),U,10)="CNT"

               SET ACHSCONP=ACHSAGRP

               SET ACHSAGRP=""

 +11       GOTO A2A

 +12      ;

A3        ;

 +1        IF '$DATA(ACHSAHDR)

               DO HDR

 +2        SET ACHSI=C

 +3        IF ACHSCTNA>C

               SET ACHSI=0

A3B       ;

 +1        SET ACHSI=$ORDER(ACHSRT(ACHSI))

 +2        IF +ACHSI=0

               GOTO A2A

 +3        SET ACHSJ=$PIECE(ACHSRT(ACHSI),U,10)

 +4        WRITE !,$JUSTIFY(ACHSI,2),?3,ACHSJ

 +5       ;BPA AGREEMENT NUMBER DISPLAY

           DO NODISP

 +6       ;W ?9,Y

 +7        WRITE ?8,Y

A3C       ;

 +1        WRITE ?27,$PIECE(ACHSRT(ACHSI),U,8),?36,$PIECE(ACHSRT(ACHSI),U,9)

 +2        IF ACHSJ="CNT"

               WRITE ?49,$PIECE(ACHSRT(ACHSI),U,2),!

               GOTO A3B

 +3        SET X=$PIECE(ACHSRT(ACHSI),U,4)

 +4        IF X=""

               IF ($PIECE(ACHSRT(ACHSI),U,2)="")

                   GOTO A3D

 +5        SET Y=$SELECT(X="Y":"YES",X="N":" NO",1:"   ")

 +6        IF Y="   "

               IF $PIECE(ACHSRT(ACHSI),U,2)=""

                   GOTO A3D

 +7        SET Y=Y_"INP: "

 +8        IF $PIECE(ACHSRT(ACHSI),U,2)'=""

               SET Y=Y_$PIECE(ACHSRT(ACHSI),U,2)

 +9        WRITE ?46,Y,!

A3D       ;

 +1        SET X=$PIECE(ACHSRT(ACHSI),U,5)

 +2        IF X=""&($PIECE(ACHSRT(ACHSI),U,3)="")

               GOTO A3E

 +3        SET Y=$SELECT(X="Y":"YES",X="N":" NO",1:"   ")

 +4        IF Y="   "

               IF $PIECE(ACHSRT(ACHSI),U,3)=""

                   GOTO A3E

 +5        SET Y=Y_"  OUT: "

 +6        IF $PIECE(ACHSRT(ACHSI),U,3)'=""

               SET Y=Y_$PIECE(ACHSRT(ACHSI),U,3)

 +7        WRITE ?46,Y,!

A3E       ;

 +1        IF $PIECE(ACHSRT(ACHSI),U,7)'=""

               WRITE ?49,"PRO: ",$PIECE(ACHSRT(ACHSI),U,7),!

 +2        GOTO A3B

 +3       ;

EXIT      ;

 +1        KILL Y,X,ACHSCT

 +2        QUIT 

 +3       ;

HDR       ;

 +1       ;W !!," #",?3,"Type",?9,"Number",?20,"Eff-Date",?30,"Exp-Date",?40,"MCR",?45,"Description",!?3,"----",?9,"---------",?20,"--------",?30,"--------",?40,"---",?45,"----------------------------"

 +2        WRITE !!," #",?3,"Type",?14,"Number",?27,"Eff-Date",?36,"Exp-Date",?45,"MCR",?49,"Description",!?3,"----",?8,"------------------",?27,"--------",?36,"--------",?45,"---",?49,"----------------------------"

 +3        QUIT 

 +4       ;

NODISP    ;DISPLAY BPA AGREEMENT STUFF

 +1        SET Y=""

 +2        IF ACHSJ="CNT"

               SET Y=$PIECE(ACHSRT(ACHSI),U)

               QUIT 

 +3        SET Y=$EXTRACT($PIECE(ACHSRT(ACHSI),U),1,2)_$SELECT(ACHSJ="BPA":"-A-",ACHSJ="PA":"-PA-",ACHSJ="RQ":"-R-",1:"")

 +4        SET X=$EXTRACT($PIECE(ACHSRT(ACHSI),U),3,6)

 +5       ;ACHS*3.1*15 IHS.OIT.FCJ ADDED FOR NEW FORMAT OF RATE #

           IF ACHSJ="RQ"

               IF $LENGTH($PIECE(ACHSRT(ACHSI),U))>6

                   SET Y=$PIECE(ACHSRT(ACHSI),U)

                   QUIT 

 +6       ;ACHS*3.1*15 IHS.OIT.FCJ

           IF ACHSJ="PA"

               SET Y=$SELECT($LENGTH($PIECE(ACHSRT(ACHSI),U))>6:$PIECE(ACHSRT(ACHSI),U),1:Y_$EXTRACT(X,2,4))

               QUIT 

 +7        SET Y=Y_$EXTRACT(X,1,4)

 +8        QUIT 

 +9       ;