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 ;
