IB20PT8A ;ALB/CPM - EXPORT ROUTINE 'DG3PR2' ; 24-FEB-94
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;
DG3PR2 ;ALB/MIR - CONTINUATION OF THE THIRD PARTY REIMBURSEMENT ; NOV 21 90@8
;;5.3;Registration;**26**;Aug 13, 1993
S DGINS=0 W !!,"INSURANCE TYPE",?24,"INSURANCE #",?45,"GROUP #",?63,"EXPIRES HOLDER",!,"--------- ----",?24,"--------- -",?45,"----- -",?63,"------- ------"
D ALL^IBCNS1(DFN,"DGIBINS") F I=0:0 S I=$O(DGIBINS(I)) Q:'I S J=DGIBINS(I,0) S X=$G(^DIC(36,+J,0)) W !,$S($P(X,"^",2)="N":"*",1:""),$E($P(X,"^",1),1,22),?24,$P(J,"^",2),?45,$P(J,"^",3) S DGINS=$S($P(X,"^",2)="N":1,1:0) D INS2
I DGINS W !?22,"* - Insurer may not reimburse!"
K DGINS,DGIBINS
S Y=+DGAD X ^DD("DD") W !!,"Admitted: ",Y,?40,"Discharged: " S Y=+DGDC I Y X ^DD("DD") W Y
I $P(DGAD,"^",18)=9 W !,"Transferred in From ",$S($D(^DIC(4,+$P(DGAD,"^",5),0)):$P(^(0),"^",1),1:"")
S DGPTF=$P(DGAD,"^",16) I 'DGPTF!('$D(^DGPT(+DGPTF,0))) W !,"No PTF Record Exists" Q
I '$D(^DGP(45.84,DGPTF)) W !,"PTF Record not closed",!
K ^UTILITY("DG") F I=0:0 S I=$O(^DGPT(DGPTF,"M",I)) Q:'I S J=^(I,0) S:$P(J,"^",2) ^UTILITY("DG",$J,"M",+$P(J,"^",10))=J
F I=0:0 S I=$O(^DGPT(DGPTF,"S",I)) Q:'I D HEAD:$Y>(IOSL-5) Q:'DGFL S J=^DGPT(DGPTF,"S",I,0),^UTILITY("DG",$J,"S",+J)=J
Q:'DGFL I $O(^UTILITY("DG",$J,"M",0)) W !!,"DATE",?22,"LOS BEDSECTION",?39,"LOS",?45,"DIAGNOSES",!,"----",?22,"---------------",?39,"---- ---------"
S DGPR=DGAD F I=0:0 S I=$O(^UTILITY("DG",$J,"M",I)) Q:'I S J=^(I) D HEAD:$Y>(IOSL-5) Q:'DGFL S Y=I X ^DD("DD") D LOL W !,Y,?22,$E($S($D(^DIC(42.4,+$P(J,"^",2),0)):$P(^(0),"^",1),1:""),1,16),?39,$J(DGLOL,4) D DIAG S DGPR=I
Q:'DGFL S DGPMIFN=DGCA D ^DGPMLOS W !?39,"---- ----------",!?26,"TOTAL LOS:",?39,$J(+$P(X,"^",5),4),?45,$S($D(^ICD9(+$S($D(^DGPT(DGPTF,70)):$P(^(70),"^",10),1:""),0)):"DXLS: "_$P(^(0),"^",1)_" ("_$P(^(0),"^",3)_")",1:"")
Q:'$O(^UTILITY("DG",$J,"S",0)) D HEAD:$Y>(IOSL-10) Q:'DGFL W !!,"SURGERY DATE",?22,"SPECIALTY",?45,"OP CODES",!,"------------",?22,"----------",?44,"--------"
F I=0:0 S I=$O(^UTILITY("DG",$J,"S",I)) Q:'I S J=^(I),Y=I X ^DD("DD") W !,Y,?22,$E($S($D(^DIC(45.3,+$P(J,"^",3),0)):$P(^(0),"^",2),1:""),1,16) D OP
Q
DIAG S M=0 F K=5:1:15 I K'=10 S L=$P(J,"^",K) I L W:M ! W ?45,$S($D(^ICD9(+L,0)):$P(^(0),"^",1)_" ("_$P(^(0),"^",3)_")",1:"") S M=1
Q
OP S M=0 F K=8:1:12 S L=$P(J,"^",K) I L W:M ! W ?45,$S($D(^ICD0(+L,0)):$P(^(0),"^",1)_" ("_$P(^(0),"^",4)_")",1:"") S M=1
Q
LOL S X1=I,X2=DGPR D DTC S DGLOL=X
F K=DGPR+.0000005:0 S K=$O(^DGPM("APCA",DFN,DGCA,K)) Q:'K!(K>I) S C=$O(^(+K,0)) I $D(^DGPM(+C,0)),"^2^3^13^43^44^45^"[("^"_$P(^(0),"^",18)_"^") S X1=$O(^DGPM("APCA",DFN,DGCA,K)),X1=$S('X1:I,X1>I:I,1:X1),X2=K D DTC S DGLOL=DGLOL-X
Q
HEAD N I,J,K,L,M,Y I $E(IOST,1)="C" S DIR(0)="E" D ^DIR S DGFL=Y I 'DGFL Q
W @IOF,!,"THIRD PARTY REIMBURSEMENT",?49,"PRINTED: ",DGNOW
W !,"("_$P(^DPT(DFN,0),"^",1)_")",!
Q
INS2 ;insurance data continued
I $P(X,"^",2)="N" S DGINS=1
S X=$P(J,"^",4) W:X]"" ?63,$E(X,4,5),"/",$E(X,6,7),"/",$E(X,2,3) S X=$P(J,"^",6) W ?73,$S(X="v":"VETERAN",X="s":"SPOUSE",X="o":"OTHER",1:"UNKNOWN")
Q
DTC N I,J,K,L,M,Y D ^%DTC Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20PT8A 3161 printed Sep 23, 2025@19:41:49 Page 2
IB20PT8A ;ALB/CPM - EXPORT ROUTINE 'DG3PR2' ; 24-FEB-94
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;
DG3PR2 ;ALB/MIR - CONTINUATION OF THE THIRD PARTY REIMBURSEMENT ; NOV 21 90@8
+1 ;;5.3;Registration;**26**;Aug 13, 1993
+2 SET DGINS=0
WRITE !!,"INSURANCE TYPE",?24,"INSURANCE #",?45,"GROUP #",?63,"EXPIRES HOLDER",!,"--------- ----",?24,"--------- -",?45,"----- -",?63,"------- ------"
+3 DO ALL^IBCNS1(DFN,"DGIBINS")
FOR I=0:0
SET I=$ORDER(DGIBINS(I))
if 'I
QUIT
SET J=DGIBINS(I,0)
SET X=$GET(^DIC(36,+J,0))
WRITE !,$SELECT($PIECE(X,"^",2)="N":"*",1:""),$EXTRACT($PIECE(X,"^",1),1,22),?24,$PIECE(J,"^",2),?45,$PIECE(J,"^",3)
SET DGINS=$SELECT($PIECE(X,"^",2)="N":1,1:0)
DO INS2
+4 IF DGINS
WRITE !?22,"* - Insurer may not reimburse!"
+5 KILL DGINS,DGIBINS
+6 SET Y=+DGAD
XECUTE ^DD("DD")
WRITE !!,"Admitted: ",Y,?40,"Discharged: "
SET Y=+DGDC
IF Y
XECUTE ^DD("DD")
WRITE Y
+7 IF $PIECE(DGAD,"^",18)=9
WRITE !,"Transferred in From ",$SELECT($DATA(^DIC(4,+$PIECE(DGAD,"^",5),0)):$PIECE(^(0),"^",1),1:"")
+8 SET DGPTF=$PIECE(DGAD,"^",16)
IF 'DGPTF!('$DATA(^DGPT(+DGPTF,0)))
WRITE !,"No PTF Record Exists"
QUIT
+9 IF '$DATA(^DGP(45.84,DGPTF))
WRITE !,"PTF Record not closed",!
+10 KILL ^UTILITY("DG")
FOR I=0:0
SET I=$ORDER(^DGPT(DGPTF,"M",I))
if 'I
QUIT
SET J=^(I,0)
if $PIECE(J,"^",2)
SET ^UTILITY("DG",$JOB,"M",+$PIECE(J,"^",10))=J
+11 FOR I=0:0
SET I=$ORDER(^DGPT(DGPTF,"S",I))
if 'I
QUIT
if $Y>(IOSL-5)
DO HEAD
if 'DGFL
QUIT
SET J=^DGPT(DGPTF,"S",I,0)
SET ^UTILITY("DG",$JOB,"S",+J)=J
+12 if 'DGFL
QUIT
IF $ORDER(^UTILITY("DG",$JOB,"M",0))
WRITE !!,"DATE",?22,"LOS BEDSECTION",?39,"LOS",?45,"DIAGNOSES",!,"----",?22,"---------------",?39,"---- ---------"
+13 SET DGPR=DGAD
FOR I=0:0
SET I=$ORDER(^UTILITY("DG",$JOB,"M",I))
if 'I
QUIT
SET J=^(I)
if $Y>(IOSL-5)
DO HEAD
if 'DGFL
QUIT
SET Y=I
XECUTE ^DD("DD")
DO LOL
WRITE !,Y,?22,$EXTRACT($SELECT($DATA(^DIC(42.4,+$PIECE(J,"^",2),0)):$PIECE(^(0),"^",1),1:""),1,16),?39,$JUSTIFY(DGLOL,4)
DO DIAG
SET DGPR=I
+14 if 'DGFL
QUIT
SET DGPMIFN=DGCA
DO ^DGPMLOS
WRITE !?39,"---- ----------",!?26,"TOTAL LOS:",?39,$JUSTIFY(+$PIECE(X,"^",5),4),?45,$SELECT($DATA(^ICD9(+$SELECT($DATA(^DGPT(DGPTF,70)):$PIECE(^(70),"^",10),1:""),0)):"DXLS: "_$PIECE(^(0),"^",1)_" ("_$PIECE(^(0),"^",3)_")",1:"")
+15 if '$ORDER(^UTILITY("DG",$JOB,"S",0))
QUIT
if $Y>(IOSL-10)
DO HEAD
if 'DGFL
QUIT
WRITE !!,"SURGERY DATE",?22,"SPECIALTY",?45,"OP CODES",!,"------------",?22,"----------",?44,"--------"
+16 FOR I=0:0
SET I=$ORDER(^UTILITY("DG",$JOB,"S",I))
if 'I
QUIT
SET J=^(I)
SET Y=I
XECUTE ^DD("DD")
WRITE !,Y,?22,$EXTRACT($SELECT($DATA(^DIC(45.3,+$PIECE(J,"^",3),0)):$PIECE(^(0),"^",2),1:""),1,16)
DO OP
+17 QUIT
DIAG SET M=0
FOR K=5:1:15
IF K'=10
SET L=$PIECE(J,"^",K)
IF L
if M
WRITE !
WRITE ?45,$SELECT($DATA(^ICD9(+L,0)):$PIECE(^(0),"^",1)_" ("_$PIECE(^(0),"^",3)_")",1:"")
SET M=1
+1 QUIT
OP SET M=0
FOR K=8:1:12
SET L=$PIECE(J,"^",K)
IF L
if M
WRITE !
WRITE ?45,$SELECT($DATA(^ICD0(+L,0)):$PIECE(^(0),"^",1)_" ("_$PIECE(^(0),"^",4)_")",1:"")
SET M=1
+1 QUIT
LOL SET X1=I
SET X2=DGPR
DO DTC
SET DGLOL=X
+1 FOR K=DGPR+.0000005:0
SET K=$ORDER(^DGPM("APCA",DFN,DGCA,K))
if 'K!(K>I)
QUIT
SET C=$ORDER(^(+K,0))
IF $DATA(^DGPM(+C,0))
IF "^2^3^13^43^44^45^"[("^"_$PIECE(^(0),"^",18)_"^")
SET X1=$ORDER(^DGPM("APCA",DFN,DGCA,K))
SET X1=$SELECT('X1:I,X1>I:I,1:X1)
SET X2=K
DO DTC
SET DGLOL=DGLOL-X
+2 QUIT
HEAD NEW I,J,K,L,M,Y
IF $EXTRACT(IOST,1)="C"
SET DIR(0)="E"
DO ^DIR
SET DGFL=Y
IF 'DGFL
QUIT
+1 WRITE @IOF,!,"THIRD PARTY REIMBURSEMENT",?49,"PRINTED: ",DGNOW
+2 WRITE !,"("_$PIECE(^DPT(DFN,0),"^",1)_")",!
+3 QUIT
INS2 ;insurance data continued
+1 IF $PIECE(X,"^",2)="N"
SET DGINS=1
+2 SET X=$PIECE(J,"^",4)
if X]""
WRITE ?63,$EXTRACT(X,4,5),"/",$EXTRACT(X,6,7),"/",$EXTRACT(X,2,3)
SET X=$PIECE(J,"^",6)
WRITE ?73,$SELECT(X="v":"VETERAN",X="s":"SPOUSE",X="o":"OTHER",1:"UNKNOWN")
+3 QUIT
DTC NEW I,J,K,L,M,Y
DO ^%DTC
QUIT
