- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20PT89 1563 printed Mar 13, 2025@21:10:25 Page 2
- 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
