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

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

initial load of FOIAVistA 6/30/08 version

File size: 1.4 KB
Line 
1DG3PR1 ;ALB/JDS/MIR - 3rd PARTY REIMBURSEMENT SORT/PRINT ; 3 MAY 90@8P
2 ;;5.3;Registration;**26,570**;Aug 13, 1993
3SORT S (DGFL,DGTIME)=1 F DGI=DGFR:0 S DGI=$O(^DGPM(DGBY,DGI)) Q:'DGI!(DGI>DGTO)!'DGFL F DGJ=0:0 S DGJ=$O(^DGPM(DGBY,DGI,DGJ)) Q:'DGJ D PRINT Q:'DGFL
4 D Q^DG3PR Q
5PRINT ;OUTPUT
6 Q:'$D(^DGPM(+DGJ,0)) I DGBY[3 S DGDC=^(0),DGCA=$P(DGDC,"^",14),DGAD=$S($D(^DGPM(+DGCA,0)):^(0),1:"")
7 I DGBY[1 S DGAD=^(0),DGCA=DGJ,DGDC=$S($D(^DGPM(+$P(DGAD,"^",17),0)):^(0),1:"")
8 S DFN=$P(DGAD,"^",3)
9 I $S('DFN:1,'$D(^DPT(DFN,0)):1,'$$INSUR^IBBAPI(DFN,"","R"):1,'$D(^DPT(DFN,"VET")):1,$P(^("VET"),"^",1)'="Y":1,1:0) Q
10 I 'DGTIME,($E(IOST,1)="C") S DIR(0)="E" D ^DIR S DGFL=Y Q:'DGFL
11 S DGTIME=0 W @IOF,!,"THIRD PARTY REIMBURSEMENT",?49,"PRINTED: " D NOW^%DTC S Y=% X ^DD("DD") W Y S DGNOW=Y
12 W !!,$P(^DPT(DFN,0),"^",1),?39,"EMPLOYMENT STATUS: " S DGX=$S($D(^DPT(DFN,.311)):^(.311),1:""),X1=$P(DGX,"^",15)
13 W $S(X1=1:"EMPLOYED FULL TIME",X1=2:"EMPLOYED PART TIME",X1=3:"NOT EMPLOYED",X1=4:"SELF EMPLOYED",X1=5:"RETIRED",X1=6:"ACTIVE MILITARY DUTY",1:"UNKNOWN")
14 D PID^VADPT6 W !,"(PT ID: ",VA("PID"),")",?48,"EMPLOYER: ",$P(DGX,"^",1) S X=$S($D(^DPT(DFN,.11)):^(.11),1:"") W !,$P(X,"^",1),?46,"OCCUPATION: ",$P(^DPT(DFN,0),"^",7)
15 I $P(X,"^",2)]"" W !,$P(X,"^",2) I $P(X,"^",3)]"" W !,$P(X,"^",3)
16 I $P(X,"^",4)]"" W !,$P(X,"^",4),", ",$S($D(^DIC(5,+$P(X,"^",5),0)):$P(^(0),"^",1),1:"")," "
17 S Y=$P(X,U,12) D ZIPOUT^VAFADDR W Y
18 D ^DG3PR2
19 Q
Note: See TracBrowser for help on using the repository browser.