- A1B2T3 ;ALB/EG EXTRACT FROM ODS FILES AND PUT IN MESSAGE 3 ; JAN 12 1991
- ;;Version 1.55 (local for MAS v5 sites);;
- DIS ;use AX x-ref from 11500.3
- Q:'$D(^A1B2(11500.3,"AX",A1B2TR)) S A1B2DA="" F AI=1:1 S A1B2DA=$O(^A1B2(11500.3,"AX",A1B2TR,A1B2DA)) Q:A1B2DA="" S A1B2PTR=$P(^A1B2(11500.3,A1B2DA,0),U,2) I (A1B2PTR'=""),($D(^A1B2(11500.1,A1B2PTR))>0) D DIS1
- Q
- DIS1 ;use EN^DIQ1
- S FL=11500.3,DIC="^A1B2(11500.3,",DA=A1B2DA,DIQ="ODS(",DIQ(0)="I",DR=".01;.03;.07;.08;.09;.1;.11;.12;.14;.15" D EN^DIQ1 S A1B2FAC=+ODS(FL,DA,.07,"I")
- S ^UTILITY("TRN",$J,A1B2TR,4,KNT,0)="$DIS"_U_ODS(FL,DA,.01,"I")_U_ODS(FL,DA,.03,"I")_U_U_U_ODS(FL,DA,.07,"I")_U_ODS(FL,DA,.08,"I")_U_ODS(FL,DA,.09,"I")_U
- S ^UTILITY("TRN",$J,A1B2TR,4,KNT,0)=^(0)_ODS(FL,DA,.1,"I")_U_ODS(FL,DA,.11,"I")_U_ODS(FL,DA,.12,"I")_U_ODS(FL,DA,.14,"I")_U_ODS(FL,DA,.15,"I"),KNT=KNT+1,KNT4=KNT4+1
- S ^UTILITY("TRN2",$J,A1B2TR,FL,A1B2DA)="" K DIC,DA,DIQ,DIQ(0),DR,ODS D:'$D(^UTILITY("TRN",$J,A1B2TR,1,A1B2PTR)) PAT^A1B2T1
- Q
- BIL ;billing record
- F AI1=5:1:8 S KNT(AI1)=0
- F FL1=11500.61,11500.62,11500.63,11500.64 S FLB=$S(FL1=11500.61:"$BIL",FL1=11500.62:"$PRO",FL1=11500.63:"$DIA",FL1=11500.64:"$ASC",1:0),FLC=(FL1*100)-1150056,KNT=0 D BIL1
- K A1B2BA,A1B2DA,A1B2FAC,A1B2PTR,AI,AI1,AI2,AI3,AJ,AJ9,FL,FLC,KNT,KNT4
- Q
- BIL1 Q:'$D(^A1B2(FL1,"AX",A1B2TR)) S A1B2BA="" F AI2=1:1 S A1B2BA=$O(^A1B2(FL1,"AX",A1B2TR,A1B2BA)) Q:A1B2BA="" S AJ9=$S($D(^A1B2(FL1,A1B2BA,0)):$P(^(0),U,2),1:0) D:(AJ9'=0)&(AJ9'="")&('$D(^UTILITY("TRN2",$J,A1B2TR,FL1,A1B2BA))) BIL2
- Q
- BIL2 S DIC="^A1B2("_FL1_",",DA=A1B2BA,DIQ="ODS(",DIQ(0)="I",DR=".01;.02;.03;.04;.05;.07;.08;.09;.12;.14;.15;.16;.2;.21" D EN^DIQ1 S A1B2FAC=+ODS(FL1,DA,.07,"I"),DR=".01",DIQ(0)="E" D EN^DIQ1
- F AI3=.01,.02,.03,.04,.05,.07,.08,.09,.12,.14,.15,.16,.2,.21 S:'$D(ODS(FL1,DA,AI3,"I")) (ODS(FL1,DA,AI3,"I"),ODS(FL1,DA,AI3,"I"))=""
- S AJ=FLB_"^^^^^^^^^^^^^"
- S $P(AJ,U,2)=ODS(FL1,DA,.01,"E"),$P(AJ,U,3)=ODS(FL1,DA,.03,"I"),$P(AJ,U,6)=ODS(FL1,DA,.07,"I"),$P(AJ,U,7)=ODS(FL1,DA,.08,"I"),$P(AJ,U,8)=ODS(FL1,DA,.09,"I"),$P(AJ,U,11)=ODS(FL1,DA,.12,"I")
- S $P(AJ,U,12)=ODS(FL1,DA,.14,"I"),$P(AJ,U,13)=ODS(FL1,DA,.15,"I"),$P(AJ,U,14)=ODS(FL1,DA,.16,"I")
- I FLC=6 S $P(AJ,U,3)=ODS(FL1,DA,.03,"I")
- I FLC=8 S $P(AJ,U,2)=ODS(FL1,DA,.01,"I"),$P(AJ,U,4)=ODS(FL1,DA,.04,"I"),$P(AJ,U,5)=ODS(FL1,DA,.05,"I")
- S KNT=KNT+1,KNT(FLC)=KNT(FLC)+1,^UTILITY("TRN",$J,A1B2TR,FLC,KNT,0)=AJ
- S ^UTILITY("TRN2",$J,A1B2TR,FL1,A1B2BA)="" K DIC,DIQ,DR
- I '$D(^UTILITY("TRN2",$J,A1B2TR,11500.2,ODS(FL1,DA,.02,"I"))) S A1B2DA=ODS(FL1,DA,.02,"I"),A1B2PTR=ODS(FL1,DA,.12,"I"),FL=11500.2 K ODS D ADM1^A1B2T1
- K DA,ODS
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HA1B2T3 2620 printed Mar 13, 2025@21:26:16 Page 2
- A1B2T3 ;ALB/EG EXTRACT FROM ODS FILES AND PUT IN MESSAGE 3 ; JAN 12 1991
- +1 ;;Version 1.55 (local for MAS v5 sites);;
- DIS ;use AX x-ref from 11500.3
- +1 if '$DATA(^A1B2(11500.3,"AX",A1B2TR))
- QUIT
- SET A1B2DA=""
- FOR AI=1:1
- SET A1B2DA=$ORDER(^A1B2(11500.3,"AX",A1B2TR,A1B2DA))
- if A1B2DA=""
- QUIT
- SET A1B2PTR=$PIECE(^A1B2(11500.3,A1B2DA,0),U,2)
- IF (A1B2PTR'="")
- IF ($DATA(^A1B2(11500.1,A1B2PTR))>0)
- DO DIS1
- +2 QUIT
- DIS1 ;use EN^DIQ1
- +1 SET FL=11500.3
- SET DIC="^A1B2(11500.3,"
- SET DA=A1B2DA
- SET DIQ="ODS("
- SET DIQ(0)="I"
- SET DR=".01;.03;.07;.08;.09;.1;.11;.12;.14;.15"
- DO EN^DIQ1
- SET A1B2FAC=+ODS(FL,DA,.07,"I")
- +2 SET ^UTILITY("TRN",$JOB,A1B2TR,4,KNT,0)="$DIS"_U_ODS(FL,DA,.01,"I")_U_ODS(FL,DA,.03,"I")_U_U_U_ODS(FL,DA,.07,"I")_U_ODS(FL,DA,.08,"I")_U_ODS(FL,DA,.09,"I")_U
- +3 SET ^UTILITY("TRN",$JOB,A1B2TR,4,KNT,0)=^(0)_ODS(FL,DA,.1,"I")_U_ODS(FL,DA,.11,"I")_U_ODS(FL,DA,.12,"I")_U_ODS(FL,DA,.14,"I")_U_ODS(FL,DA,.15,"I")
- SET KNT=KNT+1
- SET KNT4=KNT4+1
- +4 SET ^UTILITY("TRN2",$JOB,A1B2TR,FL,A1B2DA)=""
- KILL DIC,DA,DIQ,DIQ(0),DR,ODS
- if '$DATA(^UTILITY("TRN",$JOB,A1B2TR,1,A1B2PTR))
- DO PAT^A1B2T1
- +5 QUIT
- BIL ;billing record
- +1 FOR AI1=5:1:8
- SET KNT(AI1)=0
- +2 FOR FL1=11500.61,11500.62,11500.63,11500.64
- SET FLB=$SELECT(FL1=11500.61:"$BIL",FL1=11500.62:"$PRO",FL1=11500.63:"$DIA",FL1=11500.64:"$ASC",1:0)
- SET FLC=(FL1*100)-1150056
- SET KNT=0
- DO BIL1
- +3 KILL A1B2BA,A1B2DA,A1B2FAC,A1B2PTR,AI,AI1,AI2,AI3,AJ,AJ9,FL,FLC,KNT,KNT4
- +4 QUIT
- BIL1 if '$DATA(^A1B2(FL1,"AX",A1B2TR))
- QUIT
- SET A1B2BA=""
- FOR AI2=1:1
- SET A1B2BA=$ORDER(^A1B2(FL1,"AX",A1B2TR,A1B2BA))
- if A1B2BA=""
- QUIT
- SET AJ9=$SELECT($DATA(^A1B2(FL1,A1B2BA,0)):$PIECE(^(0),U,2),1:0)
- if (AJ9'=0)&(AJ9'="")&('$DATA(^UTILITY("TRN2",$JOB,A1B2TR,FL1,A1B2BA)))
- DO BIL2
- +1 QUIT
- BIL2 SET DIC="^A1B2("_FL1_","
- SET DA=A1B2BA
- SET DIQ="ODS("
- SET DIQ(0)="I"
- SET DR=".01;.02;.03;.04;.05;.07;.08;.09;.12;.14;.15;.16;.2;.21"
- DO EN^DIQ1
- SET A1B2FAC=+ODS(FL1,DA,.07,"I")
- SET DR=".01"
- SET DIQ(0)="E"
- DO EN^DIQ1
- +1 FOR AI3=.01,.02,.03,.04,.05,.07,.08,.09,.12,.14,.15,.16,.2,.21
- if '$DATA(ODS(FL1,DA,AI3,"I"))
- SET (ODS(FL1,DA,AI3,"I"),ODS(FL1,DA,AI3,"I"))=""
- +2 SET AJ=FLB_"^^^^^^^^^^^^^"
- +3 SET $PIECE(AJ,U,2)=ODS(FL1,DA,.01,"E")
- SET $PIECE(AJ,U,3)=ODS(FL1,DA,.03,"I")
- SET $PIECE(AJ,U,6)=ODS(FL1,DA,.07,"I")
- SET $PIECE(AJ,U,7)=ODS(FL1,DA,.08,"I")
- SET $PIECE(AJ,U,8)=ODS(FL1,DA,.09,"I")
- SET $PIECE(AJ,U,11)=ODS(FL1,DA,.12,"I")
- +4 SET $PIECE(AJ,U,12)=ODS(FL1,DA,.14,"I")
- SET $PIECE(AJ,U,13)=ODS(FL1,DA,.15,"I")
- SET $PIECE(AJ,U,14)=ODS(FL1,DA,.16,"I")
- +5 IF FLC=6
- SET $PIECE(AJ,U,3)=ODS(FL1,DA,.03,"I")
- +6 IF FLC=8
- SET $PIECE(AJ,U,2)=ODS(FL1,DA,.01,"I")
- SET $PIECE(AJ,U,4)=ODS(FL1,DA,.04,"I")
- SET $PIECE(AJ,U,5)=ODS(FL1,DA,.05,"I")
- +7 SET KNT=KNT+1
- SET KNT(FLC)=KNT(FLC)+1
- SET ^UTILITY("TRN",$JOB,A1B2TR,FLC,KNT,0)=AJ
- +8 SET ^UTILITY("TRN2",$JOB,A1B2TR,FL1,A1B2BA)=""
- KILL DIC,DIQ,DR
- +9 IF '$DATA(^UTILITY("TRN2",$JOB,A1B2TR,11500.2,ODS(FL1,DA,.02,"I")))
- SET A1B2DA=ODS(FL1,DA,.02,"I")
- SET A1B2PTR=ODS(FL1,DA,.12,"I")
- SET FL=11500.2
- KILL ODS
- DO ADM1^A1B2T1
- +10 KILL DA,ODS
- +11 QUIT
