source: FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DG3PR2.m@ 794

Last change on this file since 794 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.9 KB
Line 
1DG3PR2 ;ALB/MIR - CONTINUATION OF THE THIRD PARTY REIMBURSEMENT ; NOV 21 90@8
2 ;;5.3;Registration;**26,606,617,570**;Aug 13, 1993
3 S DGINS=0 W !!,"INSURANCE TYPE",?24,"INSURANCE #",?45,"GROUP #",?63,"EXPIRES HOLDER",!,"--------- ----",?24,"--------- -",?45,"----- -",?63,"------- ------"
4 ;570
5 ;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
6 N DGX,DGDATA
7 I $$INSUR^IBBAPI(DFN,,"R",.DGDATA,"1,8,9,11,12,14,18")
8 S DGX="DGDATA(""IBBAPI"",""INSUR"")" M DGIBINS=@DGX
9 F I=0:0 S I=$O(DGIBINS(I)) Q:'I D
10 . W !,$S('+DGIBINS(I,9):"*",1:" "),$E($P(DGIBINS(I,1),"^",2),1,22),?24,DGIBINS(I,14),?45
11 . I $D(DGIBINS(I,18)) W $G(DGIBINS(I,18)) ; Group Policy number
12 . S DGINS=$S($P(DGIBINS(I,9),U,2)="NO":1,1:0) D INS2
13 ;
14 I DGINS W !?22,"* - Insurer may not reimburse!"
15 K DGINS,DGIBINS
16 S Y=+DGAD X ^DD("DD") W !!,"Admitted: ",Y,?40,"Discharged: " S Y=+DGDC I Y X ^DD("DD") W Y
17 I $P(DGAD,"^",18)=9 W !,"Transferred in From ",$S($D(^DIC(4,+$P(DGAD,"^",5),0)):$P(^(0),"^",1),1:"")
18 S DGPTF=$P(DGAD,"^",16) I 'DGPTF!('$D(^DGPT(+DGPTF,0))) W !,"No PTF Record Exists" Q
19 I '$D(^DGP(45.84,DGPTF)) W !,"PTF Record not closed",!
20 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
21 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
22 Q:'DGFL I $O(^UTILITY("DG",$J,"M",0)) W !!,"DATE",?22,"LOS BEDSECTION",?39,"LOS",?45,"DIAGNOSES",!,"----",?22,"---------------",?39,"---- ---------"
23 N DGDAT,DXD
24 S DGDAT=$P(^DGPT(DGPTF,0),"^",2)
25 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 (DGDAT,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
26 ;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:"")
27 Q:'DGFL S DGPMIFN=DGCA
28 D ^DGPMLOS W !?39,"---- ----------",!?26,"TOTAL LOS:",?39,$J(+$P(X,"^",5),4) S DXD=+$S($D(^DGPT(DGPTF,70)):$P(^(70),"^",10),1:0),DXD=$S(+DXD:$$ICDDX^ICDCODE(DXD,DGDAT),1:"") W ?45,$S(+DXD>0:"DXLS: "_$P(DXD,"^",2)_" ("_$P(DXD,"^",4)_")",1:"")
29 Q:'$O(^UTILITY("DG",$J,"S",0)) D HEAD:$Y>(IOSL-10) Q:'DGFL W !!,"SURGERY DATE",?22,"SPECIALTY",?45,"OP CODES",!,"------------",?22,"----------",?44,"--------"
30 F I=0:0 S I=$O(^UTILITY("DG",$J,"S",I)) Q:'I S J=^(I),(DGDAT,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
31 Q
32DIAG S M=0 F K=5:1:15 I K'=10 S L=$P(J,"^",K) I L S DXD=$$ICDDX^ICDCODE(+L,$G(DGDAT)) W:M ! W ?45,$S(+DXD>0:$P(DXD,"^",2)_" ("_$P(DXD,"^",4)_")",1:"") S M=1
33 Q
34OP S M=0 F K=8:1:12 S L=$P(J,"^",K) I L S DXD=$$ICDOP^ICDCODE(+L,$G(DGDAT)) W:M ! W ?45,$S(+DXD>0:$P(DXD,"^",2)_" ("_$P(DXD,"^",5)_")",1:"") S M=1
35 Q
36LOL S X1=I,X2=DGPR D DTC S DGLOL=X
37 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
38 Q
39HEAD N I,J,K,L,M,Y I $E(IOST,1)="C" S DIR(0)="E" D ^DIR S DGFL=Y I 'DGFL Q
40 W @IOF,!,"THIRD PARTY REIMBURSEMENT",?49,"PRINTED: ",DGNOW
41 W !,"("_$P(^DPT(DFN,0),"^",1)_")",!
42 Q
43INS2 ;insurance data continued
44 ;570
45 N X
46 ;I $P(X,"^",2)="N" S DGINS=1
47 ;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")
48 I $P(DGIBINS(I,9),U,2)="NO" S DGINS=1
49 S X=DGIBINS(I,11) W:X]"" ?63,$$FMTE^XLFDT(X,"2D")
50 S X=$P(DGIBINS(I,12),U) W ?73,$S(X="P":"VETERAN",X="S":"SPOUSE",X="O":"OTHER",1:"UNKNOWN")
51 Q
52DTC N I,J,K,L,M,Y D ^%DTC Q
Note: See TracBrowser for help on using the repository browser.