- DG3PR2 ;ALB/MIR - CONTINUATION OF THE THIRD PARTY REIMBURSEMENT ;NOV 21 90@8
- ;;5.3;Registration;**26,606,617,570,850**;Aug 13, 1993;Build 171
- S DGINS=0 W !!,"INSURANCE TYPE",?24,"INSURANCE #",?45,"GROUP #",?63,"EXPIRES HOLDER",!,"--------- ----",?24,"--------- -",?45,"----- -",?63,"------- ------"
- ;570
- ;D ALL^IBCNS1(DFN,"DGIBINS") F I=0:0 S I=$O(DGIBINS(I)) Q:'I S J=DGIBINS(I,0) S X=$G(^DIC(36,+J,0)) W !,$S($P(X,"^",2)="N":"*",1:""),$E($P(X,"^",1),1,22),?24,$P(J,"^",2),?45,$P(J,"^",3) S DGINS=$S($P(X,"^",2)="N":1,1:0) D INS2
- N DGX,DGDATA
- N EFFDATE,IMPDATE
- I $$INSUR^IBBAPI(DFN,,"R",.DGDATA,"1,8,9,11,12,14,18")
- S DGX="DGDATA(""IBBAPI"",""INSUR"")" M DGIBINS=@DGX
- F I=0:0 S I=$O(DGIBINS(I)) Q:'I D
- . W !,$S('+DGIBINS(I,9):"*",1:" "),$E($P(DGIBINS(I,1),"^",2),1,22),?24,DGIBINS(I,14),?45
- . I $D(DGIBINS(I,18)) W $G(DGIBINS(I,18)) ; Group Policy number
- . S DGINS=$S($P(DGIBINS(I,9),U,2)="NO":1,1:0) D INS2
- ;
- I DGINS W !?22,"* - Insurer may not reimburse!"
- K DGINS,DGIBINS
- S Y=+DGAD X ^DD("DD") W !!,"Admitted: ",Y,?40,"Discharged: " S Y=+DGDC I Y X ^DD("DD") W Y
- I $P(DGAD,"^",18)=9 W !,"Transferred in From ",$S($D(^DIC(4,+$P(DGAD,"^",5),0)):$P(^(0),"^",1),1:"")
- S DGPTF=$P(DGAD,"^",16) I 'DGPTF!('$D(^DGPT(+DGPTF,0))) W !,"No PTF Record Exists" Q
- D EFFDATE^DGPTIC10(DGPTF)
- I '$D(^DGP(45.84,DGPTF)) W !,"PTF Record not closed",!
- K ^UTILITY("DG") F I=0:0 S I=$O(^DGPT(DGPTF,"M",I)) Q:'I S J=^(I,0) S:$P(J,"^",2) ^UTILITY("DG",$J,"M",+$P(J,"^",10))=J
- F I=0:0 S I=$O(^DGPT(DGPTF,"S",I)) Q:'I D HEAD:$Y>(IOSL-5) Q:'DGFL S J=^DGPT(DGPTF,"S",I,0),^UTILITY("DG",$J,"S",+J)=J
- Q:'DGFL I $O(^UTILITY("DG",$J,"M",0)) D
- . W !!,"DATE",?22,"LOS BEDSECTION",?39,"LOS",?45,"DIAGNOSES",$$GETLABEL^DGPTIC10(EFFDATE,"D"),!,"----",?22,"---------------",?39,"---- --------------------"
- N DGDAT,DXD
- S DGDAT=$P(^DGPT(DGPTF,0),"^",2)
- S DGPR=DGAD F I=0:0 S I=$O(^UTILITY("DG",$J,"M",I)) Q:'I S J=^(I) D HEAD:$Y>(IOSL-5) Q:'DGFL S (DGDAT,Y)=I X ^DD("DD") D LOL W !,Y,?22,$E($S($D(^DIC(42.4,+$P(J,"^",2),0)):$P(^(0),"^",1),1:""),1,16),?39,$J(DGLOL,4) D DIAG S DGPR=I
- Q:'DGFL S DGPMIFN=DGCA
- D ^DGPMLOS W !?39,"---- ----------",!?26,"TOTAL LOS:",?39,$J(+$P(X,"^",5),4)
- S DXD=+$S($D(^DGPT(DGPTF,70)):$P(^(70),"^",10),1:0),DXD=$S(+DXD:$$ICDDATA^ICDXCODE("DIAG",DXD,EFFDATE),1:"")
- W ?45,$S(+DXD>0:"DXLS: "_$P(DXD,"^",2)_" ("_$P(DXD,"^",4)_")",1:"")
- Q:'$O(^UTILITY("DG",$J,"S",0)) D HEAD:$Y>(IOSL-10) Q:'DGFL D
- . W !!,"SURGERY DATE",?22,"SPECIALTY",?45,"OP CODES",$$GETLABEL^DGPTIC10(EFFDATE,"P"),!,"------------",?22,"----------",?44,"--------------------"
- F I=0:0 S I=$O(^UTILITY("DG",$J,"S",I)) Q:'I S J=^(I),(DGDAT,Y)=I X ^DD("DD") W !,Y,?22,$E($S($D(^DIC(45.3,+$P(J,"^",3),0)):$P(^(0),"^",2),1:""),1,16) D OP
- Q
- DIAG ;
- S M=0 F K=5:1:15 I K'=10 S L=$P(J,"^",K) I L D
- . S DXD=$$ICDDATA^ICDXCODE("DIAG",+L,EFFDATE)
- . W:M ! W ?45,$S(+DXD>0:$P(DXD,"^",2)_" ("_$P(DXD,"^",4)_")",1:"") S M=1
- Q
- OP ;
- S M=0 F K=8:1:12 S L=$P(J,"^",K) I L D
- . S DXD=$$ICDDATA^ICDXCODE("PROC",+L,EFFDATE)
- . W:M ! W ?45,$S(+DXD>0:$P(DXD,"^",2)_" ("_$P(DXD,"^",5)_")",1:"") S M=1
- Q
- LOL S X1=I,X2=DGPR D DTC S DGLOL=X
- F K=DGPR+.0000005:0 S K=$O(^DGPM("APCA",DFN,DGCA,K)) Q:'K!(K>I) S C=$O(^(+K,0)) I $D(^DGPM(+C,0)),"^2^3^13^43^44^45^"[("^"_$P(^(0),"^",18)_"^") S X1=$O(^DGPM("APCA",DFN,DGCA,K)),X1=$S('X1:I,X1>I:I,1:X1),X2=K D DTC S DGLOL=DGLOL-X
- Q
- HEAD N I,J,K,L,M,Y I $E(IOST,1)="C" S DIR(0)="E" D ^DIR S DGFL=Y I 'DGFL Q
- W @IOF,!,"THIRD PARTY REIMBURSEMENT",?49,"PRINTED: ",DGNOW
- W !,"("_$P(^DPT(DFN,0),"^",1)_")",!
- Q
- INS2 ;insurance data continued
- N X
- I $P(DGIBINS(I,9),U,2)="NO" S DGINS=1
- S X=DGIBINS(I,11) W:X]"" ?63,$$FMTE^XLFDT(X,"2D")
- S X=$P(DGIBINS(I,12),U) W ?73,$S(X="P":"VETERAN",X="S":"SPOUSE",X="O":"OTHER",1:"UNKNOWN")
- Q
- DTC N I,J,K,L,M,Y D ^%DTC Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG3PR2 3843 printed Feb 19, 2025@00:01:31 Page 2
- DG3PR2 ;ALB/MIR - CONTINUATION OF THE THIRD PARTY REIMBURSEMENT ;NOV 21 90@8
- +1 ;;5.3;Registration;**26,606,617,570,850**;Aug 13, 1993;Build 171
- +2 SET DGINS=0
- WRITE !!,"INSURANCE TYPE",?24,"INSURANCE #",?45,"GROUP #",?63,"EXPIRES HOLDER",!,"--------- ----",?24,"--------- -",?45,"----- -",?63,"------- ------"
- +3 ;570
- +4 ;D ALL^IBCNS1(DFN,"DGIBINS") F I=0:0 S I=$O(DGIBINS(I)) Q:'I S J=DGIBINS(I,0) S X=$G(^DIC(36,+J,0)) W !,$S($P(X,"^",2)="N":"*",1:""),$E($P(X,"^",1),1,22),?24,$P(J,"^",2),?45,$P(J,"^",3) S DGINS=$S($P(X,"^",2)="N":1,1:0) D INS2
- +5 NEW DGX,DGDATA
- +6 NEW EFFDATE,IMPDATE
- +7 IF $$INSUR^IBBAPI(DFN,,"R",.DGDATA,"1,8,9,11,12,14,18")
- +8 SET DGX="DGDATA(""IBBAPI"",""INSUR"")"
- MERGE DGIBINS=@DGX
- +9 FOR I=0:0
- SET I=$ORDER(DGIBINS(I))
- if 'I
- QUIT
- Begin DoDot:1
- +10 WRITE !,$SELECT('+DGIBINS(I,9):"*",1:" "),$EXTRACT($PIECE(DGIBINS(I,1),"^",2),1,22),?24,DGIBINS(I,14),?45
- +11 ; Group Policy number
- IF $DATA(DGIBINS(I,18))
- WRITE $GET(DGIBINS(I,18))
- +12 SET DGINS=$SELECT($PIECE(DGIBINS(I,9),U,2)="NO":1,1:0)
- DO INS2
- End DoDot:1
- +13 ;
- +14 IF DGINS
- WRITE !?22,"* - Insurer may not reimburse!"
- +15 KILL DGINS,DGIBINS
- +16 SET Y=+DGAD
- XECUTE ^DD("DD")
- WRITE !!,"Admitted: ",Y,?40,"Discharged: "
- SET Y=+DGDC
- IF Y
- XECUTE ^DD("DD")
- WRITE Y
- +17 IF $PIECE(DGAD,"^",18)=9
- WRITE !,"Transferred in From ",$SELECT($DATA(^DIC(4,+$PIECE(DGAD,"^",5),0)):$PIECE(^(0),"^",1),1:"")
- +18 SET DGPTF=$PIECE(DGAD,"^",16)
- IF 'DGPTF!('$DATA(^DGPT(+DGPTF,0)))
- WRITE !,"No PTF Record Exists"
- QUIT
- +19 DO EFFDATE^DGPTIC10(DGPTF)
- +20 IF '$DATA(^DGP(45.84,DGPTF))
- WRITE !,"PTF Record not closed",!
- +21 KILL ^UTILITY("DG")
- FOR I=0:0
- SET I=$ORDER(^DGPT(DGPTF,"M",I))
- if 'I
- QUIT
- SET J=^(I,0)
- if $PIECE(J,"^",2)
- SET ^UTILITY("DG",$JOB,"M",+$PIECE(J,"^",10))=J
- +22 FOR I=0:0
- SET I=$ORDER(^DGPT(DGPTF,"S",I))
- if 'I
- QUIT
- if $Y>(IOSL-5)
- DO HEAD
- if 'DGFL
- QUIT
- SET J=^DGPT(DGPTF,"S",I,0)
- SET ^UTILITY("DG",$JOB,"S",+J)=J
- +23 if 'DGFL
- QUIT
- IF $ORDER(^UTILITY("DG",$JOB,"M",0))
- Begin DoDot:1
- +24 WRITE !!,"DATE",?22,"LOS BEDSECTION",?39,"LOS",?45,"DIAGNOSES",$$GETLABEL^DGPTIC10(EFFDATE,"D"),!,"----",?22,"---------------",?39,"---- --------------------"
- End DoDot:1
- +25 NEW DGDAT,DXD
- +26 SET DGDAT=$PIECE(^DGPT(DGPTF,0),"^",2)
- +27 SET DGPR=DGAD
- FOR I=0:0
- SET I=$ORDER(^UTILITY("DG",$JOB,"M",I))
- if 'I
- QUIT
- SET J=^(I)
- if $Y>(IOSL-5)
- DO HEAD
- if 'DGFL
- QUIT
- SET (DGDAT,Y)=I
- XECUTE ^DD("DD")
- DO LOL
- WRITE !,Y,?22,$EXTRACT($SELECT($DATA(^DIC(42.4,+$PIECE(J,"^",2),0)):$PIECE(^(0),"^",1),1:""),1,16),?39,$JUSTIFY(DGLOL,4)
- DO DIAG
- SET DGPR=I
- +28 if 'DGFL
- QUIT
- SET DGPMIFN=DGCA
- +29 DO ^DGPMLOS
- WRITE !?39,"---- ----------",!?26,"TOTAL LOS:",?39,$JUSTIFY(+$PIECE(X,"^",5),4)
- +30 SET DXD=+$SELECT($DATA(^DGPT(DGPTF,70)):$PIECE(^(70),"^",10),1:0)
- SET DXD=$SELECT(+DXD:$$ICDDATA^ICDXCODE("DIAG",DXD,EFFDATE),1:"")
- +31 WRITE ?45,$SELECT(+DXD>0:"DXLS: "_$PIECE(DXD,"^",2)_" ("_$PIECE(DXD,"^",4)_")",1:"")
- +32 if '$ORDER(^UTILITY("DG",$JOB,"S",0))
- QUIT
- if $Y>(IOSL-10)
- DO HEAD
- if 'DGFL
- QUIT
- Begin DoDot:1
- +33 WRITE !!,"SURGERY DATE",?22,"SPECIALTY",?45,"OP CODES",$$GETLABEL^DGPTIC10(EFFDATE,"P"),!,"------------",?22,"----------",?44,"--------------------"
- End DoDot:1
- +34 FOR I=0:0
- SET I=$ORDER(^UTILITY("DG",$JOB,"S",I))
- if 'I
- QUIT
- SET J=^(I)
- SET (DGDAT,Y)=I
- XECUTE ^DD("DD")
- WRITE !,Y,?22,$EXTRACT($SELECT($DATA(^DIC(45.3,+$PIECE(J,"^",3),0)):$PIECE(^(0),"^",2),1:""),1,16)
- DO OP
- +35 QUIT
- DIAG ;
- +1 SET M=0
- FOR K=5:1:15
- IF K'=10
- SET L=$PIECE(J,"^",K)
- IF L
- Begin DoDot:1
- +2 SET DXD=$$ICDDATA^ICDXCODE("DIAG",+L,EFFDATE)
- +3 if M
- WRITE !
- WRITE ?45,$SELECT(+DXD>0:$PIECE(DXD,"^",2)_" ("_$PIECE(DXD,"^",4)_")",1:"")
- SET M=1
- End DoDot:1
- +4 QUIT
- OP ;
- +1 SET M=0
- FOR K=8:1:12
- SET L=$PIECE(J,"^",K)
- IF L
- Begin DoDot:1
- +2 SET DXD=$$ICDDATA^ICDXCODE("PROC",+L,EFFDATE)
- +3 if M
- WRITE !
- WRITE ?45,$SELECT(+DXD>0:$PIECE(DXD,"^",2)_" ("_$PIECE(DXD,"^",5)_")",1:"")
- SET M=1
- End DoDot:1
- +4 QUIT
- LOL SET X1=I
- SET X2=DGPR
- DO DTC
- SET DGLOL=X
- +1 FOR K=DGPR+.0000005:0
- SET K=$ORDER(^DGPM("APCA",DFN,DGCA,K))
- if 'K!(K>I)
- QUIT
- SET C=$ORDER(^(+K,0))
- IF $DATA(^DGPM(+C,0))
- IF "^2^3^13^43^44^45^"[("^"_$PIECE(^(0),"^",18)_"^")
- SET X1=$ORDER(^DGPM("APCA",DFN,DGCA,K))
- SET X1=$SELECT('X1:I,X1>I:I,1:X1)
- SET X2=K
- DO DTC
- SET DGLOL=DGLOL-X
- +2 QUIT
- HEAD NEW I,J,K,L,M,Y
- IF $EXTRACT(IOST,1)="C"
- SET DIR(0)="E"
- DO ^DIR
- SET DGFL=Y
- IF 'DGFL
- QUIT
- +1 WRITE @IOF,!,"THIRD PARTY REIMBURSEMENT",?49,"PRINTED: ",DGNOW
- +2 WRITE !,"("_$PIECE(^DPT(DFN,0),"^",1)_")",!
- +3 QUIT
- INS2 ;insurance data continued
- +1 NEW X
- +2 IF $PIECE(DGIBINS(I,9),U,2)="NO"
- SET DGINS=1
- +3 SET X=DGIBINS(I,11)
- if X]""
- WRITE ?63,$$FMTE^XLFDT(X,"2D")
- +4 SET X=$PIECE(DGIBINS(I,12),U)
- WRITE ?73,$SELECT(X="P":"VETERAN",X="S":"SPOUSE",X="O":"OTHER",1:"UNKNOWN")
- +5 QUIT
- DTC NEW I,J,K,L,M,Y
- DO ^%DTC
- QUIT
