IB20PT89.m

IB20PT89	;ALB/CPM - EXPORT ROUTINE 'DG3PR1' ; 24-FEB-94

	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

	;

DG3PR1	;ALB/JDS/MIR - 3rd PARTY REIMBURSEMENT SORT/PRINT ; 3 MAY 90@8P

	;;5.3;Registration;**26**;Aug 13, 1993

SORT	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

	D Q^DG3PR Q

PRINT	;OUTPUT

	Q:'$D(^DGPM(+DGJ,0))  I DGBY[3 S DGDC=^(0),DGCA=$P(DGDC,"^",14),DGAD=$S($D(^DGPM(+DGCA,0)):^(0),1:"")

	I DGBY[1 S DGAD=^(0),DGCA=DGJ,DGDC=$S($D(^DGPM(+$P(DGAD,"^",17),0)):^(0),1:"")

	S DFN=$P(DGAD,"^",3) I $S('DFN:1,'$D(^DPT(DFN,0)):1,'$O(^DPT(DFN,.312,0)):1,'$D(^DPT(DFN,"VET")):1,$P(^("VET"),"^",1)'="Y":1,1:0) Q

	I 'DGTIME,($E(IOST,1)="C") S DIR(0)="E" D ^DIR S DGFL=Y Q:'DGFL

	S DGTIME=0 W @IOF,!,"THIRD PARTY REIMBURSEMENT",?49,"PRINTED:  " D NOW^%DTC S Y=% X ^DD("DD") W Y S DGNOW=Y

	W !!,$P(^DPT(DFN,0),"^",1),?39,"EMPLOYMENT STATUS:  " S DGX=$S($D(^DPT(DFN,.311)):^(.311),1:""),X1=$P(DGX,"^",15)

	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")

	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)

	I $P(X,"^",2)]"" W !,$P(X,"^",2) I $P(X,"^",3)]"" W !,$P(X,"^",3)

	I $P(X,"^",4)]"" W !,$P(X,"^",4),", ",$S($D(^DIC(5,+$P(X,"^",5),0)):$P(^(0),"^",1),1:""),"  "

	S Y=$P(X,U,12) D ZIPOUT^VAFADDR W Y

	D ^DG3PR2

	Q

IB20PT89  ;ALB/CPM - EXPORT ROUTINE 'DG3PR1' ; 24-FEB-94

 +1       ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

 +2       ;

DG3PR1    ;ALB/JDS/MIR - 3rd PARTY REIMBURSEMENT SORT/PRINT ; 3 MAY 90@8P

 +1       ;;5.3;Registration;**26**;Aug 13, 1993

SORT       SET (DGFL,DGTIME)=1

           FOR DGI=DGFR:0

               SET DGI=$ORDER(^DGPM(DGBY,DGI))

               IF 'DGI!(DGI>DGTO)!'DGFL

                   QUIT 

               FOR DGJ=0:0

                   SET DGJ=$ORDER(^DGPM(DGBY,DGI,DGJ))

                   IF 'DGJ

                       QUIT 

                   DO PRINT

                   IF 'DGFL

                       QUIT 

 +1        DO Q^DG3PR

           QUIT 

PRINT     ;OUTPUT

 +1        IF '$DATA(^DGPM(+DGJ,0))

               QUIT 

           IF DGBY[3

               SET DGDC=^(0)

               SET DGCA=$PIECE(DGDC,"^",14)

               SET DGAD=$SELECT($DATA(^DGPM(+DGCA,0)):^(0),1:"")

 +2        IF DGBY[1

               SET DGAD=^(0)

               SET DGCA=DGJ

               SET DGDC=$SELECT($DATA(^DGPM(+$PIECE(DGAD,"^",17),0)):^(0),1:"")

 +3        SET DFN=$PIECE(DGAD,"^",3)

           IF $SELECT('DFN:1,'$DATA(^DPT(DFN,0)):1,'$ORDER(^DPT(DFN,.312,0)):1,'$DATA(^DPT(DFN,"VET")):1,$PIECE(^("VET"),"^",1)'="Y":1,1:0)

               QUIT 

 +4        IF 'DGTIME

               IF ($EXTRACT(IOST,1)="C")

                   SET DIR(0)="E"

                   DO ^DIR

                   SET DGFL=Y

                   IF 'DGFL

                       QUIT 

 +5        SET DGTIME=0

           WRITE @IOF,!,"THIRD PARTY REIMBURSEMENT",?49,"PRINTED:  "

           DO NOW^%DTC

           SET Y=%

           XECUTE ^DD("DD")

           WRITE Y

           SET DGNOW=Y

 +6        WRITE !!,$PIECE(^DPT(DFN,0),"^",1),?39,"EMPLOYMENT STATUS:  "

           SET DGX=$SELECT($DATA(^DPT(DFN,.311)):^(.311),1:"")

           SET X1=$PIECE(DGX,"^",15)

 +7        WRITE $SELECT(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")

 +8        DO PID^VADPT6

           WRITE !,"(PT ID:  ",VA("PID"),")",?48,"EMPLOYER:  ",$PIECE(DGX,"^",1)

           SET X=$SELECT($DATA(^DPT(DFN,.11)):^(.11),1:"")

           WRITE !,$PIECE(X,"^",1),?46,"OCCUPATION:  ",$PIECE(^DPT(DFN,0),"^",7)

 +9        IF $PIECE(X,"^",2)]""

               WRITE !,$PIECE(X,"^",2)

               IF $PIECE(X,"^",3)]""

                   WRITE !,$PIECE(X,"^",3)

 +10       IF $PIECE(X,"^",4)]""

               WRITE !,$PIECE(X,"^",4),", ",$SELECT($DATA(^DIC(5,+$PIECE(X,"^",5),0)):$PIECE(^(0),"^",1),1:""),"  "

 +11       SET Y=$PIECE(X,U,12)

           DO ZIPOUT^VAFADDR

           WRITE Y

 +12       DO ^DG3PR2

 +13       QUIT