DG3PR1.m

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

 ;;5.3;Registration;**26,570,1015**;Aug 13, 1993;Build 21

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  ;ihs/cmi/maw no call to IB from IHS patch 1015

 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,'$$INSUR^IBBAPI(DFN,"","R"):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

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

 +1       ;;5.3;Registration;**26,570,1015**;Aug 13, 1993;Build 21

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       ;ihs/cmi/maw no call to IB from IHS patch 1015

           QUIT 

 +2        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:"")

 +3        IF DGBY[1

               SET DGAD=^(0)

               SET DGCA=DGJ

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

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

 +5        IF $SELECT('DFN:1,'$DATA(^DPT(DFN,0)):1,'$$INSUR^IBBAPI(DFN,"","R"):1,'$DATA(^DPT(DFN,"VET")):1,$PIECE(^("VET"),"^",1)'="Y":1,1:0)

               QUIT 

 +6        IF 'DGTIME

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

                   SET DIR(0)="E"

                   DO ^DIR

                   SET DGFL=Y

                   IF 'DGFL

                       QUIT 

 +7        SET DGTIME=0

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

           DO NOW^%DTC

           SET Y=%

           XECUTE ^DD("DD")

           WRITE Y

           SET DGNOW=Y

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

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

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

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

 +10       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)

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

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

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

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

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

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

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

           DO ZIPOUT^VAFADDR

           WRITE Y

 +14       DO ^DG3PR2

 +15       QUIT