A1B2MAIN ;ALB/AAS - ODS store billing data ; 17-JAN-91
;;Version 1.55 (local for MAS v5 sites);;
;
; -- main ods billing collection program
; -- Called by PTF (dgptfrel) release to store billing data
;
; -- input: DGPTIFN := ifn of ptf record in ^DGPT
;
MAIN ;
I $S('$D(DGPTIFN):1,'DGPTIFN:1,'$D(^DGPT(DGPTIFN,0)):1,$P(^(0),U,4):1,1:0) Q
D ON^A1B2UTL G:'A1B2ODS END
D FAC^A1B2UTL G:'A1B2FN END
S A1B2PTF=DGPTIFN D ADM^A1B2MUT G:'A1B2ADM END
I '$D(^A1B2(11500.2,+A1B2ADM,0)) G END
S A1B2PTFC=$S('$P(^DGPT(DGPTIFN,0),"^",9):DT,'$D(^DGP(45.84,$P(^(0),"^",9),0)):DT,'$P(^(0),"^",2):DT,1:$P(^(0),"^",2))
S DA=A1B2ADM,DIE="^A1B2(11500.2,",DR=".2////"_A1B2PTF_";.21////"_A1B2PTFC D ^DIE K DIE,DA,DR
SPC W !!,">>>> Storing Billable Specialties from PTF in ODS file. >>>>" D WAIT
I $D(^A1B2(11500.61,"C",+A1B2ADM)) S A1B2FL=11500.61 D INACT
D ^A1B2MSP ; file specialties and los in 11500.61
W !!,">>>> Storing Surgeries and Procedures in ODS files. >>>>" D WAIT,PROC
W !!,">>>> Storing Diagnoses in ODS files. >>>>" D WAIT,DIAG
W !!,"You may now enter any additional costs related to this ODS admission.",! D COST
G END
;
PROC ; -- find procedures and surgeries in ptf and store in 11500.62
; -- find surgeries
I $D(^A1B2(11500.62,"C",+A1B2ADM)) S A1B2FL=11500.62 D INACT
S A1B2EDT=0 F A1B2I=0:0 S A1B2EDT=$O(^DGPT(A1B2PTF,"S",A1B2EDT)) Q:'A1B2EDT I $D(^DGPT(A1B2PTF,"S",A1B2EDT,0)) S A1B2X=^(0),A1B2PDT=+A1B2X F A1B2J=8:1:12 S A1B2DT=$P(A1B2X,"^",A1B2J) D:A1B2DT]"" PROC1
; -- find procedures
S A1B2EDT=0 F A1B2I=0:0 S A1B2EDT=$O(^DGPT(A1B2PTF,"P",A1B2EDT)) Q:'A1B2EDT I $D(^DGPT(A1B2PTF,"P",A1B2EDT,0)) S A1B2X=^(0),A1B2PDT=+A1B2X F A1B2J=5:1:9 S A1B2DT=$P(A1B2X,"^",A1B2J) D:A1B2DT]"" PROC1
Q
;
PROC1 ; --set up to file procedures and surgeries
S A1B2FL=11500.62
D ADD^A1B2UTL
S DA=+Y,DIE="^A1B2(11500.62,",DR="[A1B2 PROCEDURE STUFF]" D ^DIE
Q
DIAG ; -- find diagnosis in ptf and file in 11500.63
I $D(^A1B2(11500.63,"C",+A1B2ADM)) S A1B2FL=11500.63 D INACT
S A1B270=$S('$D(^DGPT(A1B2PTF,70)):"",1:^(70)) Q:A1B270=""
; -- get dxls
S A1B2DT=$P(A1B270,"^",10),A1B2DXLS=1 I A1B2DT]"" D DIAG1
; -- get remaining diagnoses
S A1B2DT="" F A1B2I=16:1:24 S A1B2DXLS="",A1B2DT=$P(A1B270,"^",A1B2I) I A1B2DT]"" D DIAG1
K A1B270,A1B2DT,A1B2I
Q
;
DIAG1 ; -- set up to file
S A1B2FL=11500.63
D ADD^A1B2UTL
S DA=+Y,DIE="^A1B2(11500.63,",DR="[A1B2 DIAGNOSIS STUFF]" D ^DIE
Q
;
COST ; -- input cost data
D FAC^A1B2UTL
I '$D(A1B2ADM) G END
;
COST1 S DIC("A")="Select COST DATE: ",DIC="^A1B2(11500.64,",DIC(0)="AEQLM" D DICDR1^A1B2MUT
D ^DIC Q:Y<1 K DIC S DA=+Y
S DIE="^A1B2(11500.64,",DR="[A1B2 ENTRY]" ;I '$P(Y,"^",3),$D(^A1B2(11500.64,DA,1)),+^(1)'=2
D ^DIE
W ! G COST1
Q
;
END K A1B2DXLS,A1B2J,A1B2PDT,D0,C,A1B2X,A1B2FL,A1B2ADM1,A1B2ADM,A1B2PTF,A1B2PTFC,A1B2ODS,DIC,DIE,DA,DR,Y,X
I '$D(A1B2NTY) K A1B2FN,A1B2FNME
Q
WAIT ;
W !,"..."
W $P("HMMM^EXCUSE ME^SORRY","^",$R(3)+1),", ",$P("THIS MAY TAKE A FEW MOMENTS^LET ME PUT YOU ON 'HOLD' FOR A SECOND^HOLD ON^JUST A MOMENT PLEASE^I'M WORKING AS FAST AS I CAN^LET ME THINK ABOUT THAT A MOMENT","^",$R(6)+1)_"..."
Q
;
INACT ; -- inactivate existing entries prior to re-running
S A1B2X=0,DR=".15////0;1.01////3",DIE=A1B2FL
F A1B2I=0:0 S A1B2X=$O(^A1B2(A1B2FL,"C",+A1B2ADM,A1B2X)) Q:'A1B2X S DA=A1B2X D ^DIE
K A1B2FL,DIE,DA,DR Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HA1B2MAIN 3414 printed Apr 09, 2024@21:23:55 Page 2
A1B2MAIN ;ALB/AAS - ODS store billing data ; 17-JAN-91
+1 ;;Version 1.55 (local for MAS v5 sites);;
+2 ;
+3 ; -- main ods billing collection program
+4 ; -- Called by PTF (dgptfrel) release to store billing data
+5 ;
+6 ; -- input: DGPTIFN := ifn of ptf record in ^DGPT
+7 ;
MAIN ;
+1 IF $SELECT('$DATA(DGPTIFN):1,'DGPTIFN:1,'$DATA(^DGPT(DGPTIFN,0)):1,$PIECE(^(0),U,4):1,1:0)
QUIT
+2 DO ON^A1B2UTL
if 'A1B2ODS
GOTO END
+3 DO FAC^A1B2UTL
if 'A1B2FN
GOTO END
+4 SET A1B2PTF=DGPTIFN
DO ADM^A1B2MUT
if 'A1B2ADM
GOTO END
+5 IF '$DATA(^A1B2(11500.2,+A1B2ADM,0))
GOTO END
+6 SET A1B2PTFC=$SELECT('$PIECE(^DGPT(DGPTIFN,0),"^",9):DT,'$DATA(^DGP(45.84,$PIECE(^(0),"^",9),0)):DT,'$PIECE(^(0),"^",2):DT,1:$PIECE(^(0),"^",2))
+7 SET DA=A1B2ADM
SET DIE="^A1B2(11500.2,"
SET DR=".2////"_A1B2PTF_";.21////"_A1B2PTFC
DO ^DIE
KILL DIE,DA,DR
SPC WRITE !!,">>>> Storing Billable Specialties from PTF in ODS file. >>>>"
DO WAIT
+1 IF $DATA(^A1B2(11500.61,"C",+A1B2ADM))
SET A1B2FL=11500.61
DO INACT
+2 ; file specialties and los in 11500.61
DO ^A1B2MSP
+3 WRITE !!,">>>> Storing Surgeries and Procedures in ODS files. >>>>"
DO WAIT
DO PROC
+4 WRITE !!,">>>> Storing Diagnoses in ODS files. >>>>"
DO WAIT
DO DIAG
+5 WRITE !!,"You may now enter any additional costs related to this ODS admission.",!
DO COST
+6 GOTO END
+7 ;
PROC ; -- find procedures and surgeries in ptf and store in 11500.62
+1 ; -- find surgeries
+2 IF $DATA(^A1B2(11500.62,"C",+A1B2ADM))
SET A1B2FL=11500.62
DO INACT
+3 SET A1B2EDT=0
FOR A1B2I=0:0
SET A1B2EDT=$ORDER(^DGPT(A1B2PTF,"S",A1B2EDT))
if 'A1B2EDT
QUIT
IF $DATA(^DGPT(A1B2PTF,"S",A1B2EDT,0))
SET A1B2X=^(0)
SET A1B2PDT=+A1B2X
FOR A1B2J=8:1:12
SET A1B2DT=$PIECE(A1B2X,"^",A1B2J)
if A1B2DT]""
DO PROC1
+4 ; -- find procedures
+5 SET A1B2EDT=0
FOR A1B2I=0:0
SET A1B2EDT=$ORDER(^DGPT(A1B2PTF,"P",A1B2EDT))
if 'A1B2EDT
QUIT
IF $DATA(^DGPT(A1B2PTF,"P",A1B2EDT,0))
SET A1B2X=^(0)
SET A1B2PDT=+A1B2X
FOR A1B2J=5:1:9
SET A1B2DT=$PIECE(A1B2X,"^",A1B2J)
if A1B2DT]""
DO PROC1
+6 QUIT
+7 ;
PROC1 ; --set up to file procedures and surgeries
+1 SET A1B2FL=11500.62
+2 DO ADD^A1B2UTL
+3 SET DA=+Y
SET DIE="^A1B2(11500.62,"
SET DR="[A1B2 PROCEDURE STUFF]"
DO ^DIE
+4 QUIT
DIAG ; -- find diagnosis in ptf and file in 11500.63
+1 IF $DATA(^A1B2(11500.63,"C",+A1B2ADM))
SET A1B2FL=11500.63
DO INACT
+2 SET A1B270=$SELECT('$DATA(^DGPT(A1B2PTF,70)):"",1:^(70))
if A1B270=""
QUIT
+3 ; -- get dxls
+4 SET A1B2DT=$PIECE(A1B270,"^",10)
SET A1B2DXLS=1
IF A1B2DT]""
DO DIAG1
+5 ; -- get remaining diagnoses
+6 SET A1B2DT=""
FOR A1B2I=16:1:24
SET A1B2DXLS=""
SET A1B2DT=$PIECE(A1B270,"^",A1B2I)
IF A1B2DT]""
DO DIAG1
+7 KILL A1B270,A1B2DT,A1B2I
+8 QUIT
+9 ;
DIAG1 ; -- set up to file
+1 SET A1B2FL=11500.63
+2 DO ADD^A1B2UTL
+3 SET DA=+Y
SET DIE="^A1B2(11500.63,"
SET DR="[A1B2 DIAGNOSIS STUFF]"
DO ^DIE
+4 QUIT
+5 ;
COST ; -- input cost data
+1 DO FAC^A1B2UTL
+2 IF '$DATA(A1B2ADM)
GOTO END
+3 ;
COST1 SET DIC("A")="Select COST DATE: "
SET DIC="^A1B2(11500.64,"
SET DIC(0)="AEQLM"
DO DICDR1^A1B2MUT
+1 DO ^DIC
if Y<1
QUIT
KILL DIC
SET DA=+Y
+2 ;I '$P(Y,"^",3),$D(^A1B2(11500.64,DA,1)),+^(1)'=2
SET DIE="^A1B2(11500.64,"
SET DR="[A1B2 ENTRY]"
+3 DO ^DIE
+4 WRITE !
GOTO COST1
+5 QUIT
+6 ;
END KILL A1B2DXLS,A1B2J,A1B2PDT,D0,C,A1B2X,A1B2FL,A1B2ADM1,A1B2ADM,A1B2PTF,A1B2PTFC,A1B2ODS,DIC,DIE,DA,DR,Y,X
+1 IF '$DATA(A1B2NTY)
KILL A1B2FN,A1B2FNME
+2 QUIT
WAIT ;
+1 WRITE !,"..."
+2 WRITE $PIECE("HMMM^EXCUSE ME^SORRY","^",$RANDOM(3)+1),", ",$PIECE("THIS MAY TAKE A FEW MOMENTS^LET ME PUT YOU ON 'HOLD' FOR A SECOND^HOLD ON^JUST A MOMENT PLEASE^I'M WORKING AS FAST AS I CAN^LET ME THINK ABOUT THAT A MOMENT","^",$RANDOM(6)+1)_"
..."
+3 QUIT
+4 ;
INACT ; -- inactivate existing entries prior to re-running
+1 SET A1B2X=0
SET DR=".15////0;1.01////3"
SET DIE=A1B2FL
+2 FOR A1B2I=0:0
SET A1B2X=$ORDER(^A1B2(A1B2FL,"C",+A1B2ADM,A1B2X))
if 'A1B2X
QUIT
SET DA=A1B2X
DO ^DIE
+3 KILL A1B2FL,DIE,DA,DR
QUIT
