DG3PR1 ;ALB/JDS/MIR - 3rd PARTY REIMBURSEMENT SORT/PRINT ; 3 MAY 90@8P
;;5.3;Registration;**26,570**;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,'$$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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG3PR1 1464 printed Sep 23, 2025@20:11:15 Page 2
DG3PR1 ;ALB/JDS/MIR - 3rd PARTY REIMBURSEMENT SORT/PRINT ; 3 MAY 90@8P
+1 ;;5.3;Registration;**26,570**;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)
+4 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
+5 IF 'DGTIME
IF ($EXTRACT(IOST,1)="C")
SET DIR(0)="E"
DO ^DIR
SET DGFL=Y
if 'DGFL
QUIT
+6 SET DGTIME=0
WRITE @IOF,!,"THIRD PARTY REIMBURSEMENT",?49,"PRINTED: "
DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
WRITE Y
SET DGNOW=Y
+7 WRITE !!,$PIECE(^DPT(DFN,0),"^",1),?39,"EMPLOYMENT STATUS: "
SET DGX=$SELECT($DATA(^DPT(DFN,.311)):^(.311),1:"")
SET X1=$PIECE(DGX,"^",15)
+8 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")
+9 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)
+10 IF $PIECE(X,"^",2)]""
WRITE !,$PIECE(X,"^",2)
IF $PIECE(X,"^",3)]""
WRITE !,$PIECE(X,"^",3)
+11 IF $PIECE(X,"^",4)]""
WRITE !,$PIECE(X,"^",4),", ",$SELECT($DATA(^DIC(5,+$PIECE(X,"^",5),0)):$PIECE(^(0),"^",1),1:"")," "
+12 SET Y=$PIECE(X,U,12)
DO ZIPOUT^VAFADDR
WRITE Y
+13 DO ^DG3PR2
+14 QUIT
